├── LICENSE ├── META ├── Makefile ├── README.md ├── TODO ├── annot.ml ├── annot.mli ├── caml2html.html.mlx ├── caml2html.ml.mlx ├── caml2html.mli.mlx ├── caml2html_test.ml ├── caml2html_test2.ml ├── caml2html_test2.mli ├── depend ├── hashtbl2.ml ├── hashtbl2.mli ├── history.txt ├── input.mli ├── input.mll ├── main.ml ├── man └── caml2html.1 ├── output.ml ├── output.mli ├── output_latex.ml ├── output_latex.mli ├── plugin.ml ├── plugin.mli ├── style.css ├── tag.ml ├── test.ml └── version.ml.mlx /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 2, June 1991 3 | 4 | Copyright (C) 1989, 1991 Free Software Foundation, Inc. 5 | 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | Preamble 10 | 11 | The licenses for most software are designed to take away your 12 | freedom to share and change it. By contrast, the GNU General Public 13 | License is intended to guarantee your freedom to share and change free 14 | software--to make sure the software is free for all its users. This 15 | General Public License applies to most of the Free Software 16 | Foundation's software and to any other program whose authors commit to 17 | using it. (Some other Free Software Foundation software is covered by 18 | the GNU Library General Public License instead.) You can apply it to 19 | your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Our General Public Licenses are designed to make sure that you 23 | have the freedom to distribute copies of free software (and charge for 24 | this service if you wish), that you receive source code or can get it 25 | if you want it, that you can change the software or use pieces of it 26 | in new free programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must show them these terms so they know their 37 | rights. 38 | 39 | We protect your rights with two steps: (1) copyright the software, and 40 | (2) offer you this license which gives you legal permission to copy, 41 | distribute and/or modify the software. 42 | 43 | Also, for each author's protection and ours, we want to make certain 44 | that everyone understands that there is no warranty for this free 45 | software. If the software is modified by someone else and passed on, we 46 | want its recipients to know that what they have is not the original, so 47 | that any problems introduced by others will not reflect on the original 48 | authors' reputations. 49 | 50 | Finally, any free program is threatened constantly by software 51 | patents. We wish to avoid the danger that redistributors of a free 52 | program will individually obtain patent licenses, in effect making the 53 | program proprietary. To prevent this, we have made it clear that any 54 | patent must be licensed for everyone's free use or not licensed at all. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | GNU GENERAL PUBLIC LICENSE 60 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 61 | 62 | 0. This License applies to any program or other work which contains 63 | a notice placed by the copyright holder saying it may be distributed 64 | under the terms of this General Public License. The "Program", below, 65 | refers to any such program or work, and a "work based on the Program" 66 | means either the Program or any derivative work under copyright law: 67 | that is to say, a work containing the Program or a portion of it, 68 | either verbatim or with modifications and/or translated into another 69 | language. (Hereinafter, translation is included without limitation in 70 | the term "modification".) Each licensee is addressed as "you". 71 | 72 | Activities other than copying, distribution and modification are not 73 | covered by this License; they are outside its scope. The act of 74 | running the Program is not restricted, and the output from the Program 75 | is covered only if its contents constitute a work based on the 76 | Program (independent of having been made by running the Program). 77 | Whether that is true depends on what the Program does. 78 | 79 | 1. You may copy and distribute verbatim copies of the Program's 80 | source code as you receive it, in any medium, provided that you 81 | conspicuously and appropriately publish on each copy an appropriate 82 | copyright notice and disclaimer of warranty; keep intact all the 83 | notices that refer to this License and to the absence of any warranty; 84 | and give any other recipients of the Program a copy of this License 85 | along with the Program. 86 | 87 | You may charge a fee for the physical act of transferring a copy, and 88 | you may at your option offer warranty protection in exchange for a fee. 89 | 90 | 2. You may modify your copy or copies of the Program or any portion 91 | of it, thus forming a work based on the Program, and copy and 92 | distribute such modifications or work under the terms of Section 1 93 | above, provided that you also meet all of these conditions: 94 | 95 | a) You must cause the modified files to carry prominent notices 96 | stating that you changed the files and the date of any change. 97 | 98 | b) You must cause any work that you distribute or publish, that in 99 | whole or in part contains or is derived from the Program or any 100 | part thereof, to be licensed as a whole at no charge to all third 101 | parties under the terms of this License. 102 | 103 | c) If the modified program normally reads commands interactively 104 | when run, you must cause it, when started running for such 105 | interactive use in the most ordinary way, to print or display an 106 | announcement including an appropriate copyright notice and a 107 | notice that there is no warranty (or else, saying that you provide 108 | a warranty) and that users may redistribute the program under 109 | these conditions, and telling the user how to view a copy of this 110 | License. (Exception: if the Program itself is interactive but 111 | does not normally print such an announcement, your work based on 112 | the Program is not required to print an announcement.) 113 | 114 | These requirements apply to the modified work as a whole. If 115 | identifiable sections of that work are not derived from the Program, 116 | and can be reasonably considered independent and separate works in 117 | themselves, then this License, and its terms, do not apply to those 118 | sections when you distribute them as separate works. But when you 119 | distribute the same sections as part of a whole which is a work based 120 | on the Program, the distribution of the whole must be on the terms of 121 | this License, whose permissions for other licensees extend to the 122 | entire whole, and thus to each and every part regardless of who wrote it. 123 | 124 | Thus, it is not the intent of this section to claim rights or contest 125 | your rights to work written entirely by you; rather, the intent is to 126 | exercise the right to control the distribution of derivative or 127 | collective works based on the Program. 128 | 129 | In addition, mere aggregation of another work not based on the Program 130 | with the Program (or with a work based on the Program) on a volume of 131 | a storage or distribution medium does not bring the other work under 132 | the scope of this License. 133 | 134 | 3. You may copy and distribute the Program (or a work based on it, 135 | under Section 2) in object code or executable form under the terms of 136 | Sections 1 and 2 above provided that you also do one of the following: 137 | 138 | a) Accompany it with the complete corresponding machine-readable 139 | source code, which must be distributed under the terms of Sections 140 | 1 and 2 above on a medium customarily used for software interchange; or, 141 | 142 | b) Accompany it with a written offer, valid for at least three 143 | years, to give any third party, for a charge no more than your 144 | cost of physically performing source distribution, a complete 145 | machine-readable copy of the corresponding source code, to be 146 | distributed under the terms of Sections 1 and 2 above on a medium 147 | customarily used for software interchange; or, 148 | 149 | c) Accompany it with the information you received as to the offer 150 | to distribute corresponding source code. (This alternative is 151 | allowed only for noncommercial distribution and only if you 152 | received the program in object code or executable form with such 153 | an offer, in accord with Subsection b above.) 154 | 155 | The source code for a work means the preferred form of the work for 156 | making modifications to it. For an executable work, complete source 157 | code means all the source code for all modules it contains, plus any 158 | associated interface definition files, plus the scripts used to 159 | control compilation and installation of the executable. However, as a 160 | special exception, the source code distributed need not include 161 | anything that is normally distributed (in either source or binary 162 | form) with the major components (compiler, kernel, and so on) of the 163 | operating system on which the executable runs, unless that component 164 | itself accompanies the executable. 165 | 166 | If distribution of executable or object code is made by offering 167 | access to copy from a designated place, then offering equivalent 168 | access to copy the source code from the same place counts as 169 | distribution of the source code, even though third parties are not 170 | compelled to copy the source along with the object code. 171 | 172 | 4. You may not copy, modify, sublicense, or distribute the Program 173 | except as expressly provided under this License. Any attempt 174 | otherwise to copy, modify, sublicense or distribute the Program is 175 | void, and will automatically terminate your rights under this License. 176 | However, parties who have received copies, or rights, from you under 177 | this License will not have their licenses terminated so long as such 178 | parties remain in full compliance. 179 | 180 | 5. You are not required to accept this License, since you have not 181 | signed it. However, nothing else grants you permission to modify or 182 | distribute the Program or its derivative works. These actions are 183 | prohibited by law if you do not accept this License. Therefore, by 184 | modifying or distributing the Program (or any work based on the 185 | Program), you indicate your acceptance of this License to do so, and 186 | all its terms and conditions for copying, distributing or modifying 187 | the Program or works based on it. 188 | 189 | 6. Each time you redistribute the Program (or any work based on the 190 | Program), the recipient automatically receives a license from the 191 | original licensor to copy, distribute or modify the Program subject to 192 | these terms and conditions. You may not impose any further 193 | restrictions on the recipients' exercise of the rights granted herein. 194 | You are not responsible for enforcing compliance by third parties to 195 | this License. 196 | 197 | 7. If, as a consequence of a court judgment or allegation of patent 198 | infringement or for any other reason (not limited to patent issues), 199 | conditions are imposed on you (whether by court order, agreement or 200 | otherwise) that contradict the conditions of this License, they do not 201 | excuse you from the conditions of this License. If you cannot 202 | distribute so as to satisfy simultaneously your obligations under this 203 | License and any other pertinent obligations, then as a consequence you 204 | may not distribute the Program at all. For example, if a patent 205 | license would not permit royalty-free redistribution of the Program by 206 | all those who receive copies directly or indirectly through you, then 207 | the only way you could satisfy both it and this License would be to 208 | refrain entirely from distribution of the Program. 209 | 210 | If any portion of this section is held invalid or unenforceable under 211 | any particular circumstance, the balance of the section is intended to 212 | apply and the section as a whole is intended to apply in other 213 | circumstances. 214 | 215 | It is not the purpose of this section to induce you to infringe any 216 | patents or other property right claims or to contest validity of any 217 | such claims; this section has the sole purpose of protecting the 218 | integrity of the free software distribution system, which is 219 | implemented by public license practices. Many people have made 220 | generous contributions to the wide range of software distributed 221 | through that system in reliance on consistent application of that 222 | system; it is up to the author/donor to decide if he or she is willing 223 | to distribute software through any other system and a licensee cannot 224 | impose that choice. 225 | 226 | This section is intended to make thoroughly clear what is believed to 227 | be a consequence of the rest of this License. 228 | 229 | 8. If the distribution and/or use of the Program is restricted in 230 | certain countries either by patents or by copyrighted interfaces, the 231 | original copyright holder who places the Program under this License 232 | may add an explicit geographical distribution limitation excluding 233 | those countries, so that distribution is permitted only in or among 234 | countries not thus excluded. In such case, this License incorporates 235 | the limitation as if written in the body of this License. 236 | 237 | 9. The Free Software Foundation may publish revised and/or new versions 238 | of the General Public License from time to time. Such new versions will 239 | be similar in spirit to the present version, but may differ in detail to 240 | address new problems or concerns. 241 | 242 | Each version is given a distinguishing version number. If the Program 243 | specifies a version number of this License which applies to it and "any 244 | later version", you have the option of following the terms and conditions 245 | either of that version or of any later version published by the Free 246 | Software Foundation. If the Program does not specify a version number of 247 | this License, you may choose any version ever published by the Free Software 248 | Foundation. 249 | 250 | 10. If you wish to incorporate parts of the Program into other free 251 | programs whose distribution conditions are different, write to the author 252 | to ask for permission. For software which is copyrighted by the Free 253 | Software Foundation, write to the Free Software Foundation; we sometimes 254 | make exceptions for this. Our decision will be guided by the two goals 255 | of preserving the free status of all derivatives of our free software and 256 | of promoting the sharing and reuse of software generally. 257 | 258 | NO WARRANTY 259 | 260 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 268 | REPAIR OR CORRECTION. 269 | 270 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 278 | POSSIBILITY OF SUCH DAMAGES. 279 | 280 | END OF TERMS AND CONDITIONS 281 | 282 | How to Apply These Terms to Your New Programs 283 | 284 | If you develop a new program, and you want it to be of the greatest 285 | possible use to the public, the best way to achieve this is to make it 286 | free software which everyone can redistribute and change under these terms. 287 | 288 | To do so, attach the following notices to the program. It is safest 289 | to attach them to the start of each source file to most effectively 290 | convey the exclusion of warranty; and each file should have at least 291 | the "copyright" line and a pointer to where the full notice is found. 292 | 293 | 294 | Copyright (C) 295 | 296 | This program is free software; you can redistribute it and/or modify 297 | it under the terms of the GNU General Public License as published by 298 | the Free Software Foundation; either version 2 of the License, or 299 | (at your option) any later version. 300 | 301 | This program is distributed in the hope that it will be useful, 302 | but WITHOUT ANY WARRANTY; without even the implied warranty of 303 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 304 | GNU General Public License for more details. 305 | 306 | You should have received a copy of the GNU General Public License 307 | along with this program; if not, write to the Free Software 308 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 309 | 310 | 311 | Also add information on how to contact you by electronic and paper mail. 312 | 313 | If the program is interactive, make it output a short notice like this 314 | when it starts in an interactive mode: 315 | 316 | Gnomovision version 69, Copyright (C) year name of author 317 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 318 | This is free software, and you are welcome to redistribute it 319 | under certain conditions; type `show c' for details. 320 | 321 | The hypothetical commands `show w' and `show c' should show the appropriate 322 | parts of the General Public License. Of course, the commands you use may 323 | be called something other than `show w' and `show c'; they could even be 324 | mouse-clicks or menu items--whatever suits your program. 325 | 326 | You should also get your employer (if you work as a programmer) or your 327 | school, if any, to sign a "copyright disclaimer" for the program, if 328 | necessary. Here is a sample; alter the names: 329 | 330 | Yoyodyne, Inc., hereby disclaims all copyright interest in the program 331 | `Gnomovision' (which makes passes at compilers) written by James Hacker. 332 | 333 | , 1 April 1989 334 | Ty Coon, President of Vice 335 | 336 | This General Public License does not permit incorporating your program into 337 | proprietary programs. If your program is a subroutine library, you may 338 | consider it more useful to permit linking proprietary applications with the 339 | library. If this is what you want to do, use the GNU Library General 340 | Public License instead of this License. 341 | -------------------------------------------------------------------------------- /META: -------------------------------------------------------------------------------- 1 | name = "caml2html" 2 | version = "1.3.1" 3 | description = "Syntax highlighting for OCaml code" 4 | requires = "str unix" 5 | archive(byte) = "caml2html.cma" 6 | archive(native) = "caml2html.cmxa" 7 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | VERSION = 1.4.4 2 | export VERSION 3 | 4 | ifndef PREFIX 5 | PREFIX = $(shell dirname $(shell dirname `which ocamlc`)) 6 | endif 7 | ifndef BINDIR 8 | BINDIR = $(PREFIX)/bin 9 | endif 10 | ifndef OCAMLC 11 | OCAMLC = ocamlc 12 | endif 13 | ifndef OCAMLOPT 14 | OCAMLOPT = ocamlopt 15 | endif 16 | ifndef OCAMLLEX 17 | OCAMLLEX = ocamllex 18 | endif 19 | ifndef OCAMLDEP 20 | OCAMLDEP = ocamldep 21 | endif 22 | 23 | ifeq "$(shell $(OCAMLC) -config |grep os_type)" "os_type: Win32" 24 | EXE=caml2html.exe 25 | else 26 | EXE=caml2html 27 | endif 28 | 29 | MODULES = hashtbl2 version annot tag plugin input output output_latex main 30 | 31 | OBJS = $(patsubst %, %.cmo, $(MODULES)) 32 | OBJS-NAT = $(patsubst %, %.cmx, $(MODULES)) 33 | 34 | .PHONY: default 35 | default: $(EXE) test 36 | 37 | ### GODI targets ### 38 | .PHONY: all opt install 39 | all: byte bytelib 40 | opt: $(EXE) optlib 41 | install: 42 | install -m 0755 $(EXE) $(BINDIR) || \ 43 | install -m 0755 caml2html.byte $(BINDIR)/$(EXE) 44 | test -f caml2html.cma -o -f caml2html.cmxa && $(MAKE) libinstall 45 | uninstall: 46 | rm -f $(BINDIR)/$(EXE) 47 | $(MAKE) libuninstall || true 48 | ### end of GODI targets ### 49 | 50 | .PHONY: pre byte test lib libinstall libuninstall \ 51 | bytelib optlib tidy clean dep archive 52 | 53 | pre: version.ml caml2html.mli caml2html.ml 54 | caml2html.mli: annot.mli plugin.mli input.mli \ 55 | output.mli output_latex.mli version.ml \ 56 | caml2html.mli.mlx 57 | camlmix -clean caml2html.mli.mlx -o caml2html.mli 58 | caml2html.ml: hashtbl2.mli hashtbl2.ml tag.ml annot.ml \ 59 | plugin.ml input.ml output.ml output_latex.ml caml2html.ml.mlx 60 | camlmix -clean caml2html.ml.mlx -o caml2html.ml 61 | version.ml: version.ml.mlx Makefile 62 | camlmix -clean version.ml.mlx -o version.ml 63 | 64 | byte: caml2html.byte 65 | 66 | test: 67 | rm -f caml2html_test.mli 68 | ocamlc -i caml2html_test.ml > caml2html_test.mli 69 | ocamlc -c caml2html_test.mli 70 | ocamlc -c -dtypes caml2html_test.ml 71 | ./$(EXE) -o caml2html_test.html \ 72 | caml2html_test.mli caml2html_test.ml caml2html_test2.ml \ 73 | -ln -ie7 \ 74 | -ext date:date \ 75 | -ext cat:cat \ 76 | -ext "rot13:tr '[a-z]' '[n-za-m]'" 77 | ./$(EXE) -o caml2html_self_test.html \ 78 | tag.ml annot.mli annot.ml plugin.mli plugin.ml \ 79 | input.mli input.mll output.mli output.ml \ 80 | output_latex.mli output_latex.ml \ 81 | main.ml \ 82 | -ln 83 | ./$(EXE) -latex -o caml2html_self_test.tex \ 84 | tag.ml annot.mli annot.ml plugin.mli plugin.ml \ 85 | input.mli input.mll output.mli output.ml \ 86 | output_latex.mli output_latex.ml \ 87 | main.ml \ 88 | -ln 89 | 90 | $(EXE): $(OBJS-NAT) 91 | $(OCAMLOPT) -o $(EXE) str.cmxa unix.cmxa $(OBJS-NAT) 92 | 93 | caml2html.byte: $(OBJS) 94 | $(OCAMLC) -custom -o caml2html.byte str.cma unix.cma $(OBJS) 95 | 96 | lib: all bytelib optlib 97 | 98 | libinstall: 99 | ocamlfind install caml2html META caml2html.mli caml2html.cmi \ 100 | caml2html.*a 101 | 102 | libuninstall: 103 | ocamlfind remove caml2html 104 | 105 | bytelib: $(OBJS) caml2html.cmi caml2html.cmo 106 | $(OCAMLC) -a -o caml2html.cma caml2html.cmo 107 | 108 | optlib: $(OBJS-NAT) caml2html.cmi caml2html.cmx 109 | $(OCAMLOPT) -a -o caml2html.cmxa caml2html.cmx 110 | 111 | 112 | # remove everything that we don't want to include into the archive 113 | tidy: 114 | rm -f $(EXE) caml2html.byte \ 115 | *.cm[ixoa] *.cmxa *.a *.obj *.o *~ *.annot \ 116 | *.ml.html caml2html_test.html caml2html_self_test.html \ 117 | caml2html_self_test.tex 118 | 119 | # remove everything that is not a source file 120 | clean: tidy 121 | rm -f input.ml *.mlx.ml \ 122 | caml2html.ml caml2html.mli version.ml caml2html_test.mli \ 123 | caml2html.html caml2html-help 124 | 125 | dep: input.ml 126 | $(OCAMLDEP) hashtbl2.mli hashtbl2.ml version.ml annot.mli annot.ml \ 127 | tag.ml plugin.mli plugin.ml input.mli input.ml \ 128 | output.mli output.ml output_latex.mli output_latex.ml \ 129 | main.ml > depend 130 | 131 | .SUFFIXES: .mll .mly .ml .mli .cmi .cmo .cmx 132 | 133 | .mll.ml: 134 | $(OCAMLLEX) $< 135 | .mly.ml: 136 | $(OCAMLYACC) $< 137 | .mli.cmi: 138 | $(OCAMLC) -c $< 139 | .ml.cmo: 140 | $(OCAMLC) -dtypes -c $< 141 | .ml.cmx: 142 | $(OCAMLOPT) -dtypes -c $< 143 | 144 | -include depend 145 | 146 | input.ml: input.mll 147 | 148 | 149 | ################ Only for developers 150 | P = caml2html-$(VERSION) 151 | 152 | caml2html.html: caml2html.byte caml2html.html.mlx 153 | ./caml2html.byte -help > caml2html-help 154 | camlmix -o caml2html.html caml2html.html.mlx 155 | 156 | archive: pre opt test caml2html.html 157 | @echo "Making archive for version $(VERSION)" 158 | rm -rf /tmp/$(P) && \ 159 | cp -rp . /tmp/$(P) && \ 160 | cd /tmp/$(P) && $(MAKE) tidy && \ 161 | rm -f *~ caml2html*.tar* && \ 162 | cd .. && tar czf $(P).tar.gz $(P) && \ 163 | tar cjf $(P).tar.bz2 $(P) 164 | mv /tmp/$(P).tar.gz /tmp/$(P).tar.bz2 . 165 | cp $(P).tar.gz $(P).tar.bz2 $$WWW/ 166 | cp $(P).tar.gz $(P).tar.bz2 ../releases/ 167 | cd $$WWW/ && ln -sf $(P).tar.gz caml2html.tar.gz && \ 168 | ln -sf $(P).tar.bz2 caml2html.tar.bz2 169 | cp caml2html.html $$WWW/caml2html-help.html 170 | cp README $$WWW/caml2html-readme.txt 171 | cp history.txt $$WWW/caml2html-history.txt 172 | cp version.ml $$WWW/caml2html-version.ml 173 | cp caml2html_test.ml $$WWW/ 174 | cp caml2html_test.html $$WWW/ 175 | touch -c $$WWW/caml2html.html.mlx 176 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Caml2html 2 | ========= 3 | 4 | Caml2html is a command-line tool that highlights the syntax of OCaml 5 | source code. 6 | 7 | Requirements 8 | ------------ 9 | 10 | Caml2html needs an OCaml compiler (>= 3.00) properly installed. 11 | GNU make is required for the compilation. 12 | 13 | Compiling 14 | --------- 15 | 16 | ```bash 17 | $ make # try "make byte" if make does not work 18 | ``` 19 | 20 | Compiling the library (optional): 21 | 22 | ```bash 23 | $ make lib # try "make bytelib" if it does not work 24 | ``` 25 | 26 | Installing the executable 27 | ------------------------- 28 | 29 | ``` 30 | $ make install 31 | ``` 32 | 33 | The program is installed in the `BINDIR` 34 | directory specified at the first line of the Makefile (`/usr/bin` by 35 | default), and is named `caml2html` (even for bytecode option). 36 | 37 | Uninstalling 38 | ------------ 39 | 40 | ``` 41 | $ make uninstall 42 | ``` 43 | 44 | How to run it 45 | ------------- 46 | 47 | Type `caml2html -help`, or have a look at the [html documentation](https://mjambon.github.io/mjambon2016/caml2html.html). 48 | 49 | Authors and license 50 | ------------------- 51 | 52 | Caml2html was originally written by 53 | Sébastien Ailleret, and is now developed by Martin Jambon. 54 | It is distributed for free under a GPL license (see `LICENSE` file). 55 | -------------------------------------------------------------------------------- /TODO: -------------------------------------------------------------------------------- 1 | - add a -s option which reads the code from the command line 2 | 3 | - add "mkdir -p" feature instead of just "mkdir" 4 | 5 | - bug in ocaml compiler (3.09.2): -dtypes option on input.mll creates 6 | an input.annot file where character counts are higher than what they 7 | should be. The number of lines is correct though. 8 | -------------------------------------------------------------------------------- /annot.ml: -------------------------------------------------------------------------------- 1 | (* $Id$ *) 2 | 3 | open Printf 4 | open Scanf 5 | open Lexing 6 | 7 | type t = { start : position; 8 | stop : position; 9 | typ : string } 10 | 11 | type layer_info = { innermost : bool; 12 | outermost : bool } 13 | 14 | type tag = [ `Start of string | `Stop ] * (position * layer_info) 15 | 16 | let create_pos file line linechar char = 17 | { pos_fname = file; 18 | pos_lnum = line; 19 | pos_bol = linechar; 20 | pos_cnum = char } 21 | 22 | (* The format of .annot files provides the fields that are required 23 | by the standard Lexing.position type. 24 | That's convenient, however the pos_bol and pos_cnum are relative 25 | to the .ml file from which the information is extracted. 26 | This works if the source file is the .ml file, but if it has line directives 27 | indicating that the source is another file such as a .mll or .mly, 28 | the pos_fname and pos_lnum fields will correctly point to the 29 | source file, while the pos_bol and pos_cnum fields will point to the 30 | position in the .ml file, because line directives don't allow to retrieve 31 | this information. 32 | 33 | As a consequence, we must use the (line,char) positions and not 34 | absolute character position. 35 | *) 36 | let parse_type_data pos_line type_lines = 37 | sscanf pos_line "%S %i %i %i %S %i %i %i" 38 | (fun file1 line1 linechar1 char1 file2 line2 linechar2 char2 -> 39 | let pos1 = create_pos file1 line1 linechar1 char1 in 40 | let pos2 = create_pos file2 line2 linechar2 char2 in 41 | { start = pos1; 42 | stop = pos2; 43 | typ = String.concat "\n" type_lines }) 44 | 45 | 46 | (* Pervasives.compare is not guaranteed to work like this: *) 47 | let compare_arrays a b = 48 | let c = compare (Array.length a) (Array.length b) in 49 | if c <> 0 then c 50 | else 51 | let result = ref 0 in 52 | try 53 | for i = 0 to Array.length a - 1 do 54 | let c = compare a.(i) b.(i) in 55 | if c <> 0 then 56 | (result := c; 57 | raise Exit) 58 | done; 59 | !result 60 | with Exit -> !result 61 | 62 | let compare_tags (a, _) (b, _) = compare_arrays a b 63 | 64 | let print_pos pos = 65 | printf "%S %i %i %i\n" pos.pos_fname pos.pos_lnum pos.pos_bol pos.pos_cnum 66 | 67 | 68 | (* Generate a sequence of nested opening and closing tags. *) 69 | let tagify ~impl_file l = 70 | let info0 = { innermost = false; outermost = false } in 71 | let length x = x.stop.pos_cnum - x.start.pos_cnum in 72 | let tags = 73 | List.fold_left 74 | (fun l x -> 75 | if x.start.pos_fname <> impl_file || 76 | x.stop.pos_fname <> impl_file then l 77 | else 78 | let len = length x in 79 | let start = x.start in 80 | let stop = x.stop in 81 | let start_key = [| start.pos_lnum; start.pos_cnum - start.pos_bol; 82 | 1; -len |] in 83 | let stop_key = [| stop.pos_lnum; stop.pos_cnum - stop.pos_bol; 84 | -1; len |] in 85 | if compare_arrays start_key stop_key >= 0 then 86 | (* Bad tagging! *) 87 | (eprintf 88 | "Ignoring annotation: stop tag at or before start tag!\n%!"; 89 | l) 90 | else 91 | (start_key, (`Start x.typ, (x.start, info0))) :: 92 | (stop_key, (`Stop, (x.stop, info0))) :: l) [] l in 93 | List.map snd (List.sort compare_tags tags) 94 | 95 | (* We keep only a sequence of non-nested annotations. 96 | That's too bad, but it would have to be implemented in javascript 97 | and it's not so easy to implement something reliable. 98 | Without nesting, CSS with hover is sufficient, even in IE (but 99 | we must use elements). *) 100 | (* 101 | let rec remove_outer_tags = function 102 | ((_, `Start _) as a) :: ((_, `Stop) as b) :: l -> 103 | a :: b :: remove_outer_tags l 104 | | (_, `Start _) :: ((_, `Start _) :: _ as l) -> remove_outer_tags l 105 | | (_, `Stop) :: l -> remove_outer_tags l 106 | | [] -> [] 107 | | [(_, `Start _)] -> assert false 108 | 109 | let rec remove_inner_tags = function 110 | (_, `Start _) as start :: l -> 111 | let stop, rest = skip_tag_sequence 1 l in 112 | start :: stop :: remove_inner_tags rest 113 | | (_, `Stop) :: _ -> assert false 114 | | [] -> [] 115 | and skip_tag_sequence n = function 116 | (_, `Start _) :: l -> skip_tag_sequence (n+1) l 117 | | ((_, `Stop) as stop) :: l -> 118 | let n = n - 1 in 119 | if n = 0 then stop, l 120 | else skip_tag_sequence n l 121 | | [] -> assert false 122 | *) 123 | 124 | 125 | let set_innermost (tag, (pos, x)) = 126 | (tag, (pos, { x with innermost = true })) 127 | 128 | let set_outermost (tag, (pos, x)) = 129 | (tag, (pos, { x with outermost = true })) 130 | 131 | 132 | let rec mark_innermost = function 133 | ((`Start _, _) as a) :: ((`Stop, _) as b) :: l -> 134 | set_innermost a :: set_innermost b :: mark_innermost l 135 | | ((`Start _, _) as a) :: ((`Start _, _) :: _ as l) -> a :: mark_innermost l 136 | | ((`Stop, _) as a) :: l -> a :: mark_innermost l 137 | | [] -> [] 138 | | [(`Start _, _)] -> invalid_arg "Annot.mark_innermost" 139 | 140 | let rec mark_outermost = function 141 | (`Start _, _) as start :: l -> 142 | set_outermost start :: skip_tag_sequence 1 l 143 | | (`Stop, _) :: _ -> invalid_arg "Annot.mark_outermost" 144 | | [] -> [] 145 | 146 | and skip_tag_sequence n = function 147 | ((`Start _, _) as start) :: l -> start :: skip_tag_sequence (n+1) l 148 | | ((`Stop, _) as stop) :: l -> 149 | let n = n - 1 in 150 | if n = 0 then set_outermost stop :: mark_outermost l 151 | else stop :: skip_tag_sequence n l 152 | | [] -> invalid_arg "Annot.skip_tag_sequence" 153 | 154 | let set_layer_info l = mark_outermost (mark_innermost l) 155 | 156 | (* 157 | let z = { innermost = false; outermost = false };; 158 | let start x = (`Start x, (x, z));; 159 | let stop x = (`Stop, (x, z));; 160 | let l = 161 | [ start 1; stop 1; start 2; start 3; start 4; stop 4; stop 3; stop 2 ];; 162 | mark_outermost (mark_innermost l);; 163 | *) 164 | 165 | 166 | type filter = [ `All | `Innermost | `Outermost ] 167 | 168 | let is_field s = 169 | try 170 | for i = 0 to String.length s - 2 do 171 | match s.[i] with 172 | 'a'..'z' -> () 173 | | _ -> raise Exit 174 | done; 175 | if s = "" || s.[String.length s - 1] <> '(' then 176 | raise Exit; 177 | true 178 | with Exit -> false 179 | 180 | let is_data s = 181 | String.length s >= 2 && s.[0] = ' ' && s.[1] = ' ' 182 | 183 | let string_of_line = function 184 | `Loc s -> s 185 | | `Type -> "type(" 186 | | `Close -> ")" 187 | | `Data s -> s 188 | | `Field s -> s 189 | | `Other s -> s 190 | | `Empty -> "" 191 | 192 | let string_of_line2 = function 193 | `Loc s -> "L " ^ s 194 | | `Type -> "T " ^ "type(" 195 | | `Close -> "C " ^ ")" 196 | | `Data s -> "D " ^ s 197 | | `Field s -> "F " ^ s 198 | | `Other s -> "O " ^ s 199 | | `Empty -> "E " ^ "" 200 | 201 | let classify_line s = 202 | if s = "" then `Other s 203 | else if s.[0] = '"' then `Loc s 204 | else if s = "type(" then `Type 205 | else if s = ")" then `Close 206 | else if is_data s then `Data s 207 | else if is_field s then `Field s 208 | else `Other s 209 | 210 | let preparse_file annot_file = 211 | let ic = open_in annot_file in 212 | let l = ref [] in 213 | try 214 | while true do 215 | l := classify_line (input_line ic) :: !l 216 | done; 217 | assert false 218 | with End_of_file -> 219 | close_in ic; 220 | List.rev !l 221 | 222 | 223 | (* impl_file is the file that we want to annotate and annot_file 224 | if the file that contains the annotation information. 225 | Usually impl_file is a .ml, but it may be a .mll or .mly file. 226 | Annotation files normally end in .annot and are produced 227 | by ocamlc or ocamlopt when -dtypes is specified. 228 | Only annotations that refer to impl_file are selected. *) 229 | let parse ~impl_file ~annot_file = 230 | let rec field_loop accu l = 231 | match l with 232 | `Close :: l -> (List.rev accu, l) 233 | | `Data s :: l -> field_loop (s :: accu) l 234 | | [] -> failwith "unexpected end of file" 235 | | l -> (List.rev accu, l) 236 | in 237 | let rec body_loop type_data l = 238 | match l with 239 | `Type :: l -> 240 | let data, rem = field_loop [] l in 241 | if rem == l then type_data, l 242 | else body_loop (Some data) rem 243 | | `Field _ :: l -> 244 | let data, rem = field_loop [] l in 245 | if rem == l then type_data, l 246 | else body_loop type_data rem 247 | | l -> type_data, l 248 | in 249 | 250 | let rec main_loop accu l = 251 | match l with 252 | `Loc loc_s :: l -> 253 | let type_data, l = body_loop None l in 254 | let accu = 255 | match type_data with 256 | None -> accu 257 | | Some data_lines -> 258 | parse_type_data loc_s data_lines :: accu 259 | in 260 | main_loop accu l 261 | 262 | | `Empty :: l -> main_loop accu l 263 | | [] -> List.rev accu 264 | | x :: _ -> failwith (sprintf "junk found in annot file %S: %S" 265 | annot_file (string_of_line x)) 266 | in 267 | 268 | let l = preparse_file annot_file in 269 | (*List.iter (fun x -> print_endline (string_of_line2 x)) l;*) 270 | let l = main_loop [] l in 271 | set_layer_info (tagify ~impl_file l) 272 | 273 | let guess_annot_file file = 274 | try 275 | let name = Filename.chop_extension file ^ ".annot" in 276 | if Sys.file_exists name then Some name 277 | else None 278 | with _ -> None 279 | 280 | (* impl_file is the file to annotate. See parse function above. *) 281 | let from_file ~impl_file ~annot_file : tag list option = 282 | if Sys.file_exists annot_file then 283 | Some (parse ~impl_file ~annot_file) 284 | else None 285 | -------------------------------------------------------------------------------- /annot.mli: -------------------------------------------------------------------------------- 1 | (* $Id$ *) 2 | 3 | type layer_info = { innermost : bool; 4 | outermost : bool } 5 | 6 | type tag = [ `Start of string | `Stop ] * (Lexing.position * layer_info) 7 | 8 | type filter = [ `All | `Innermost | `Outermost ] 9 | 10 | val parse : 11 | impl_file:string -> 12 | annot_file:string -> tag list 13 | val guess_annot_file : string -> string option 14 | val from_file : impl_file:string -> annot_file:string -> tag list option 15 | -------------------------------------------------------------------------------- /caml2html.html.mlx: -------------------------------------------------------------------------------- 1 | ## 2 | #use "topfind";; 3 | #camlp4o;; 4 | #require "netstring";; 5 | #require "mikmatch_pcre";; 6 | open Mikmatch;; 7 | .## 8 | 9 | 10 | How to use Caml2html 11 | 12 | 13 | 14 |

How to use Caml2html

15 | 16 |

17 | More information about Caml2html 18 | here. 19 | 20 |

Usage

21 | 22 | 
23 | ##= Netencoding.Html.encode
24 |       ~in_enc:`Enc_iso88591
25 |       ~out_enc:`Enc_iso88591 ()
26 |       (Text.file_contents "caml2html-help") .##
27 |
28 | 29 | 30 |

Examples

31 | 32 |

Process a single file code.ml: 33 | 

caml2html code.ml
34 | 35 |

Same thing with a title for the page: 36 | 

caml2html -t code.ml
37 | 38 |

Process a file with a title and line numbers: 39 | 

caml2html -t -ln code.ml
40 | 41 |

Process a file with a title, line numbers and replace tabs by 4 spaces: 42 | 

caml2html -t -ln -tab 4 code.ml
43 | 44 |

Process a file without footnotes (the most simple output): 45 | 

caml2html -nf code.ml
46 | 47 |

Process a file and use a css (style.css): 48 | 

caml2html -css code.ml
49 | 50 |

Process a file and use a specific css (http://blabla.com/style2.css): 51 | 

caml2html -css -cssurl http://blabla.com/style2.css code.ml
52 | 53 |

Read from stdin and output to stdout: 54 | 

caml2html
55 | 56 |

Process many files into a single file: 57 | 

caml2html -o result.html *.mli *.ml
58 | 59 |

Process many files, and create one HTML page for each file: 60 | 

caml2html *.ml
61 | 62 |

Same thing, but write result in the html directory: 63 | 

caml2html -d html *.ml
64 | 65 |

Same thing, but write result in the html directory: 66 | 

caml2html -d html *.ml
67 | 68 |

You can specify the character encoding with the -charset option: 69 | 

70 | caml2html -charset euc-jp input.ml -o output.html
71 |
72 | 73 |

You can write the comments in HTML. This lets you add simple 74 | formatting such as hyperlinks. Beware that one HTML tag cannot 75 | span over several lines, and that the characters 76 | <, > and & 77 | must be written as &lt;, &gt; 78 | and &amp;. 79 | 

80 | (* This is file1.ml.
81 |    <a href="#file2.ml">This is a link to file2.ml</a>. *)
82 | ...
83 |
84 |

85 | In this case, use the -hc option: 86 | 

87 | caml2html -hc file1.ml file2.ml -o result.html
88 |
89 | 90 | 91 | 92 |
93 |

94 | This document was not generated by caml2html! 95 | 96 | 97 | -------------------------------------------------------------------------------- /caml2html.ml.mlx: -------------------------------------------------------------------------------- 1 | ##= "(* Generated by camlmix. *) 2 | (* Do not edit! *)" (* yes you can *) 3 | ## 4 | 5 | module Version = struct ## @include "version.ml" ## end 6 | 7 | module Hashtbl2 : 8 | sig 9 | ## @include "hashtbl2.mli" ## 10 | end = 11 | struct 12 | ## @include "hashtbl2.ml" ## 13 | end 14 | 15 | module Annot : 16 | sig 17 | ## @include "annot.mli" ## 18 | end = 19 | struct 20 | ## @include "annot.ml" ## 21 | end 22 | 23 | module Tag = 24 | struct 25 | ## @include "tag.ml" ## 26 | end 27 | 28 | module Plugin : 29 | sig 30 | ## @include "plugin.mli" ## 31 | end = 32 | struct 33 | ## @include "plugin.ml" ## 34 | end 35 | 36 | module Input : 37 | sig 38 | ## @include "input.mli" ## 39 | end = 40 | struct 41 | ## @include "input.ml" ## 42 | end 43 | 44 | module Output : 45 | sig 46 | ## @include "output.mli" ## 47 | end = 48 | struct 49 | ## @include "output.ml" ## 50 | end 51 | 52 | module Output_latex : 53 | sig 54 | ## @include "output_latex.mli" ## 55 | end = 56 | struct 57 | ## @include "output_latex.ml" ## 58 | end 59 | -------------------------------------------------------------------------------- /caml2html.mli.mlx: -------------------------------------------------------------------------------- 1 | ## 2 | print_string 3 | "(* Generated by camlmix. *) 4 | (* Do not edit! *)" 5 | ## 6 | 7 | module Annot : 8 | sig 9 | ## @include "annot.mli" ## 10 | end 11 | 12 | module Plugin : 13 | sig 14 | ## @include "plugin.mli" ## 15 | end 16 | 17 | module Input : 18 | sig 19 | ## @include "input.mli" ## 20 | end 21 | 22 | module Output : 23 | sig 24 | ## @include "output.mli" ## 25 | end 26 | 27 | module Output_latex : 28 | sig 29 | ## @include "output_latex.mli" ## 30 | end 31 | -------------------------------------------------------------------------------- /caml2html_test.ml: -------------------------------------------------------------------------------- 1 | 2 | (* Test file for caml2html (the first line is empty) *) 3 | 4 | (* -hc option: link to caml2html_test.mli (same page, colorized) 5 | * link to caml2html_test.ml (source) *) 6 | 7 | (* This is a multi-line "*)" 8 | comment *) 9 | 10 | open Printf 11 | 12 | type 'aa' weird = E10 13 | 14 | type t = [ `A | `b of int | ` C | ` (* *) D | ` 15 | E ] 16 | 17 | (* nested (* comments *) *) 18 | (* "multi- 19 | line string in comment" *) 20 | 21 | (*html 22 |

Hello

23 |

24 | This is 25 | HTML! 26 |

27 | *) 28 | 29 | (*date*) 30 | 31 | (*rot13 Caml2html rules! "*)" *) 32 | 33 | (*foo*) 34 | 35 | module Zero'04 = 36 | struct 37 | let characters = [ 'a'; '\000'; '\x12'; ' 38 | '; '\t'; 'z' ] 39 | let n = 0X12 + truncate 1.2E-1_2 40 | let the_Truth = 41 | let ignore4 a b c d = false in 42 | not (ignore4 1._0_ None 1.0E10 E10) 43 | end 44 | 45 | let hel'Lo = "\"Hello \ 46 | World!\"" 47 | 48 | let ( |* ) a b = 49 | match a, b with 50 | 1, 0 | 0, 1 -> 1+1 51 | | _ -> 0 52 | 53 | let _ = 54 | assert true; 55 | if 0 mod 1 < 1 && `Abc <> `def then 56 | print_endline hel'Lo 57 | ;; 58 | 59 | (* long types *) 60 | let t x = (x, x) 61 | let a x = t (t x) 62 | let b x = a (a x) 63 | let _ = fun x -> b (b x) 64 | ;; 65 | 66 | #123 "file.ml" (* line directives are not parsed, sorry... *) 67 | 68 | -------------------------------------------------------------------------------- /caml2html_test2.ml: -------------------------------------------------------------------------------- 1 | let add_operator ~name ~level ~value = 2 | EXTEND 3 | Pcaml.expr: LEVEL $level$ [ 4 | [ x = SELF; $name$; y = SELF -> 5 | <:expr< $value$ $x$ $y$ >> ] 6 | ]; 7 | END 8 | 9 | EXTEND 10 | Pcaml.str_item: [ 11 | [ "OPERATOR"; name = STRING; "LEVEL"; level = STRING; 12 | "VALUE"; value = Pcaml.expr; "END" -> 13 | add_operator 14 | ~name:(Token.eval_string _loc name) 15 | ~level:(Token.eval_string _loc level) 16 | ~value; 17 | <:str_item< declare end >> ] 18 | ]; 19 | END 20 | 21 | 22 | 23 | let expand _loc e = 24 | <:expr< 1 + 25 | $e$ >> 26 | -------------------------------------------------------------------------------- /caml2html_test2.mli: -------------------------------------------------------------------------------- 1 | val add_operator : name:string -> level:string -> value:MLast.expr -> unit 2 | val expand : MLast.loc -> MLast.expr -> MLast.expr 3 | -------------------------------------------------------------------------------- /depend: -------------------------------------------------------------------------------- 1 | hashtbl2.cmi : 2 | hashtbl2.cmo : hashtbl2.cmi 3 | hashtbl2.cmx : hashtbl2.cmi 4 | annot.cmi : 5 | annot.cmo : annot.cmi 6 | annot.cmx : annot.cmi 7 | tag.cmo : 8 | tag.cmx : 9 | plugin.cmi : 10 | plugin.cmo : plugin.cmi 11 | plugin.cmx : plugin.cmi 12 | input.cmi : annot.cmi 13 | input.cmo : tag.cmo plugin.cmi annot.cmi input.cmi 14 | input.cmx : tag.cmx plugin.cmx annot.cmx input.cmi 15 | output.cmi : input.cmi annot.cmi 16 | output.cmo : plugin.cmi input.cmi hashtbl2.cmi annot.cmi output.cmi 17 | output.cmx : plugin.cmx input.cmx hashtbl2.cmx annot.cmx output.cmi 18 | output_latex.cmi : input.cmi 19 | output_latex.cmo : plugin.cmi input.cmi output_latex.cmi 20 | output_latex.cmx : plugin.cmx input.cmx output_latex.cmi 21 | main.cmo : plugin.cmi output_latex.cmi output.cmi input.cmi 22 | main.cmx : plugin.cmx output_latex.cmx output.cmx input.cmx 23 | -------------------------------------------------------------------------------- /hashtbl2.ml: -------------------------------------------------------------------------------- 1 | type ('a, 'b) t = ('a, 'b list ref) Hashtbl.t 2 | 3 | let create n = Hashtbl.create n 4 | let clear = Hashtbl.clear 5 | 6 | let add tbl key data = 7 | let r = 8 | try Hashtbl.find tbl key 9 | with Not_found -> 10 | let r = ref [] in 11 | Hashtbl.add tbl key r; 12 | r in 13 | r := data :: !r 14 | 15 | let copy tbl = 16 | let tbl2 = Hashtbl.copy tbl in 17 | Hashtbl.iter (fun key r -> Hashtbl.replace tbl2 key (ref !r)) tbl; 18 | tbl2 19 | 20 | let find tbl key = 21 | List.hd !(Hashtbl.find tbl key) 22 | 23 | let find_all tbl key = 24 | !(Hashtbl.find tbl key) 25 | 26 | let mem = Hashtbl.mem 27 | 28 | let remove tbl key = 29 | try 30 | let r = Hashtbl.find tbl key in 31 | match !r with 32 | [data] -> Hashtbl.remove tbl key 33 | | hd :: tl -> r := tl 34 | | [] -> invalid_arg "remove" 35 | with Not_found -> () 36 | 37 | let remove_all = Hashtbl.remove 38 | 39 | let replace tbl key data = 40 | try 41 | let r = Hashtbl.find tbl key in 42 | r := data :: (List.tl !r) 43 | with 44 | Not_found -> Hashtbl.add tbl key (ref [data]) 45 | 46 | let replace_all tbl key l = 47 | try 48 | let r = Hashtbl.find tbl key in 49 | r := l 50 | with 51 | Not_found -> Hashtbl.add tbl key (ref l) 52 | 53 | let iter f tbl = 54 | Hashtbl.iter (fun key r -> f key (List.hd !r)) tbl 55 | 56 | let iter_all f tbl = 57 | Hashtbl.iter (fun key r -> f key !r) tbl 58 | 59 | let fold f tbl init = 60 | Hashtbl.fold (fun key r accu -> f key (List.hd !r) accu) tbl init 61 | 62 | let fold_all f tbl init = 63 | Hashtbl.fold 64 | (fun key r accu -> f key !r accu) 65 | tbl init 66 | 67 | let list_keys tbl = 68 | fold (fun key _ accu -> key :: accu) tbl [] 69 | 70 | let list_values tbl = 71 | fold (fun _ data accu -> data :: accu) tbl [] 72 | 73 | let list_all_values tbl = 74 | fold_all (fun _ l accu -> l :: accu) tbl [] 75 | 76 | let list tbl = 77 | fold (fun key data accu -> (key, data) :: accu) tbl [] 78 | 79 | let list_all tbl = 80 | fold_all (fun key l accu -> (key, l) :: accu) tbl [] 81 | 82 | let of_list n l = 83 | let tbl = create n in 84 | List.iter (fun (key, data) -> add tbl key data) l; 85 | tbl 86 | 87 | let of_keys n l = 88 | let tbl = create n in 89 | List.iter (fun key -> replace tbl key ()) l; 90 | tbl 91 | -------------------------------------------------------------------------------- /hashtbl2.mli: -------------------------------------------------------------------------------- 1 | (** This module provides a kind of hash tables where each key is 2 | present only once in the table, as opposed to the naive usage of 3 | the standard [Hashtbl] module. 4 | Its main purpose is to provide efficient implementation 5 | of functions such as [list_keys] with enhanced safety 6 | over the direct use of an [('a, 'b list ref) Hashtbl.t] type. 7 | Many functions have two variants: 8 | - the first one is applied only on the current bindings, like 9 | [iter]. 10 | - the second one has the [_all] suffix like [iter_all] 11 | and is applied to the list of 12 | all the values that are bound to the given key 13 | instead of only to the topmost value. 14 | This list of values 15 | is prebuilt, so there is no cost for building the list when 16 | such a function is applied. 17 | 18 | Example - clustering elements: 19 | 20 | [Hashtbl2.list_all (Hashtbl2.of_list 10 [ (1, "a"); (2, "b"); (1, "c") ])] 21 | 22 | returns [[(2, ["b"]); (1, ["c"; "a"])]]. 23 | 24 | [Hashtbl2] is an additional layer over the standard [Hashtbl] module. 25 | 26 | @author Martin Jambon *) 27 | 28 | type ('a, 'b) t 29 | (** The type of hash tables from type ['a] to type ['b]. 30 | This representation is suitable for clustering elements 31 | according to the given keys. *) 32 | 33 | val create : int -> ('a, 'b) t 34 | (** [Hashtbl2.create n] creates a new, empty hash table, with 35 | initial size [n]. For best results, [n] should be on the 36 | order of the expected number of elements that will be in 37 | the table. The table grows as needed, so [n] is just an 38 | initial guess. *) 39 | 40 | val clear : ('a, 'b) t -> unit 41 | (** Empty a hash table. *) 42 | 43 | val add : ('a, 'b) t -> 'a -> 'b -> unit 44 | (** [Hashtbl2.add tbl x y] adds a binding of [x] to [y] in table [tbl]. 45 | Previous bindings for [x] are not removed, but simply 46 | hidden. That is, after performing {!Hashtbl2.remove}[ tbl x], 47 | the previous binding for [x], if any, is restored. 48 | (Same behavior as with association lists.) *) 49 | 50 | val copy : ('a, 'b) t -> ('a, 'b) t 51 | (** Return a copy of the given hashtable. *) 52 | 53 | val find : ('a, 'b) t -> 'a -> 'b 54 | (** [Hashtbl2.find tbl x] returns the current binding of [x] in [tbl], 55 | or raises [Not_found] if no such binding exists. *) 56 | 57 | val find_all : ('a, 'b) t -> 'a -> 'b list 58 | (** [Hashtbl2.find_all tbl x] returns the list of all data 59 | associated with [x] in [tbl]. 60 | The current binding is returned first, then the previous 61 | bindings, in reverse order of introduction in the table. *) 62 | 63 | val mem : ('a, 'b) t -> 'a -> bool 64 | (** [Hashtbl2.mem tbl x] checks if [x] is bound in [tbl]. *) 65 | 66 | val remove : ('a, 'b) t -> 'a -> unit 67 | (** [Hashtbl2.remove tbl x] removes the current binding of [x] in [tbl], 68 | restoring the previous binding if it exists. 69 | It does nothing if [x] is not bound in [tbl]. *) 70 | 71 | val remove_all : ('a, 'b) t -> 'a -> unit 72 | (** [Hashtbl2.remove_all tbl x] removes all bindings of [x] in [tbl]. 73 | It does nothing if [x] is not bound in [tbl]. *) 74 | 75 | val replace : ('a, 'b) t -> 'a -> 'b -> unit 76 | (** [Hashtbl2.replace tbl x y] replaces the current binding of [x] 77 | in [tbl] by a binding of [x] to [y]. If [x] is unbound in [tbl], 78 | a binding of [x] to [y] is added to [tbl]. 79 | This is functionally equivalent to {!Hashtbl2.remove}[ tbl x] 80 | followed by {!Hashtbl2.add}[ tbl x y]. *) 81 | 82 | val replace_all : ('a, 'b) t -> 'a -> 'b list -> unit 83 | (** [Hashtbl2.replace_all tbl x y] replaces all bindings of [x] 84 | in [tbl] by bindings of [x] to the elements of [y]. 85 | The first element of [y] defines the current binding, 86 | the second element is the defined the previous binding, and so on. *) 87 | 88 | val iter : ('a -> 'b -> unit) -> ('a, 'b) t -> unit 89 | (** [Hashtbl2.iter f tbl] applies [f] to current bindings in table [tbl]. 90 | [f] receives the key as first argument, and the associated value 91 | as second argument. Each current binding is presented exactly once to [f]. 92 | Hidden bindings are ignored. 93 | The order in which the bindings are passed to [f] is unspecified. *) 94 | 95 | val iter_all : ('a -> 'b list -> unit) -> ('a, 'b) t -> unit 96 | (** [Hashtbl2.iter_all f tbl] applies [f] to all bindings in table [tbl]. 97 | [f] receives the key as first argument, and all the associated values 98 | as second argument in reverse order of introduction in the table. 99 | The order in which the bindings are passed to [f] is unspecified. *) 100 | 101 | val fold : ('a -> 'b -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c 102 | (** [Hashtbl2.fold f tbl init] computes 103 | [(f kN dN ... (f k1 d1 init)...)], 104 | where [k1 ... kN] are the keys of current bindings in [tbl], 105 | and [d1 ... dN] are the associated values. 106 | Each current binding is presented exactly once to [f]. 107 | Hidden bindings are ignored. *) 108 | 109 | val fold_all : ('a -> 'b list -> 'c -> 'c) -> ('a, 'b) t -> 'c -> 'c 110 | (** [Hashtbl2.fold_all f tbl init] computes 111 | [(f kN lN ... (f k1 l1 init)...)], 112 | where [k1 ... kN] are the keys of all bindings in [tbl], 113 | and [l1 ... lN] are the lists of associated values, in reverse order 114 | of introduction in the table. *) 115 | 116 | 117 | val list_keys : ('a, 'b) t -> 'a list 118 | (** [Hashtbl2.list_keys tbl] returns a list of all the keys 119 | from the current bindings. Therefore no key is duplicated. 120 | Order is unspecified. *) 121 | 122 | val list_values : ('a, 'b) t -> 'b list 123 | (** [Hashtbl2.list_values tbl] returns a list of all the values 124 | from the current bindings. Hidden bindings are ignored. 125 | Order is unspecified. *) 126 | 127 | val list_all_values : ('a, 'b) t -> 'b list list 128 | (** [Hashtbl2.list_all_values tbl] returns a list of all the values 129 | from all bindings. Order is unspecified. *) 130 | 131 | val list : ('a, 'b) t -> ('a * 'b) list 132 | (** [Hashtbl2.list tbl] returns a list of the current bindings. 133 | Order is unspecified. *) 134 | 135 | val list_all : ('a, 'b) t -> ('a * 'b list) list 136 | (** [Hashtbl2.list_all tbl] returns a list of all the bindings clustered 137 | according to their key. Order is unspecified. *) 138 | 139 | val of_list : int -> ('a * 'b) list -> ('a, 'b) t 140 | (** [Hashtbl2.of_list n l] converts a list of bindings into 141 | a hash table of initial size [n]. The ordering of the list is the order 142 | of introduction of the bindings in the table. *) 143 | 144 | val of_keys : int -> 'a list -> ('a, unit) t 145 | (** [Hashtbl2.of_keys n l] converts a list of elements into 146 | a hash table of initial size [n] containing unique copies of these 147 | elements bound at most one time to [()]. *) 148 | -------------------------------------------------------------------------------- /history.txt: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mjambon/caml2html/297a7d2695896a2de8110d2acd4d64c85eb29805/history.txt -------------------------------------------------------------------------------- /input.mli: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2004 Martin Jambon 3 | 4 | This file is distributed under the terms of the GNU Public License 5 | http://www.gnu.org/licenses/gpl.txt 6 | *) 7 | 8 | (* 9 | This module provides functions that parse OCaml source code and return 10 | a list of tokens which are suitable for automatic syntax highlighting. 11 | Any input is accepted. Only a lexical analysis is performed and thus can 12 | be used to highlight incorrect programs as well as derivatives 13 | of OCaml (.ml .mli .mll .mly). 14 | *) 15 | 16 | type token = 17 | [ `Comment of string (** a (fragment of) comment *) 18 | | `Special_comment of string * string (** (handler name, full comment) *) 19 | | `Construct of string (** an uppercase identifier or 20 | an identifier starting with ` *) 21 | | `Keyword of string (** a keyword *) 22 | | `Newline (** a newline character *) 23 | | `String of string (** a (fragment of) string or character literal *) 24 | | `Quotation of string (** a camlp4 quotation *) 25 | | `Tab (** a tabulation character *) 26 | | `Token of string (** anything else *) 27 | | `Start_annot of (Annot.layer_info * string) (** start of a type annotation 28 | read from .annot file *) 29 | | `Stop_annot of Annot.layer_info ] (** end of a type annotation 30 | read from .annot file *) 31 | 32 | val parse : 33 | ?annot:Annot.tag list -> Lexing.lexbuf -> token list 34 | val string : 35 | ?filename:string -> ?annot:Annot.tag list -> string -> token list 36 | val channel : 37 | ?filename:string -> ?annot:Annot.tag list -> in_channel -> token list 38 | val file : 39 | ?annot:Annot.tag list -> string -> token list 40 | -------------------------------------------------------------------------------- /input.mll: -------------------------------------------------------------------------------- 1 | (* $Id$ *) 2 | { 3 | (* 4 | Copyright 2002-2004 Sebastien Ailleret 5 | Copyright 2004-2006 Martin Jambon 6 | 7 | This file is distributed under the terms of the GNU Public License 8 | http://www.gnu.org/licenses/gpl.txt 9 | *) 10 | 11 | open Printf 12 | open Lexing 13 | 14 | type token = [ `Comment of string 15 | | `Special_comment of string * string 16 | | `Construct of string 17 | | `Keyword of string 18 | | `Newline 19 | | `String of string 20 | | `Quotation of string 21 | | `Tab 22 | | `Token of string 23 | | `Start_annot of (Annot.layer_info * string) 24 | | `Stop_annot of Annot.layer_info ] 25 | 26 | type state = { mutable depth : int; 27 | buf : Buffer.t; 28 | lexbuf : lexbuf; 29 | mutable tokens : token list; 30 | mutable annot_tags : Annot.tag list; 31 | mutable in_group : bool } 32 | 33 | let init_state annot_tags lexbuf = { depth = 0; 34 | buf = Buffer.create 1000; 35 | lexbuf = lexbuf; 36 | tokens = []; 37 | annot_tags = annot_tags; 38 | in_group = false } 39 | 40 | let stringpair_of_token = function 41 | `Comment s -> "Comment", s 42 | | `Construct s -> "Construct", s 43 | | `Keyword s -> "Keyword", s 44 | | `Newline -> "Newline", "" 45 | | `String s -> "String", s 46 | | `Quotation s -> "Quotation", s 47 | | `Tab -> "Tab", "" 48 | | `Token s -> "Token", s 49 | | `Start_annot (_info, s) -> "Start_annot", s 50 | | `Stop_annot _info -> "Stop_annot", "" 51 | 52 | let string_of_token x = 53 | match stringpair_of_token x with 54 | a, "" -> a 55 | | a, b -> sprintf "%s %S" a b 56 | 57 | let print_tokens l = 58 | List.iter (fun s -> 59 | printf "%s\n" (string_of_token s)) 60 | l 61 | 62 | let keywords = [ 63 | "and"; 64 | "as"; 65 | "asr"; 66 | "assert"; 67 | "begin"; 68 | "class"; 69 | "constraint"; 70 | "do"; 71 | "done"; 72 | "downto"; 73 | "else"; 74 | "end"; 75 | "exception"; 76 | "external"; 77 | "false"; 78 | "for"; 79 | "fun"; 80 | "function"; 81 | "functor"; 82 | "if"; 83 | "in"; 84 | "include"; 85 | "inherit"; 86 | "initializer"; 87 | "land"; 88 | "lazy"; 89 | "let"; 90 | "lor"; 91 | "lsl"; 92 | "lsr"; 93 | "lxor"; 94 | "match"; 95 | "method"; 96 | "mod"; 97 | "module"; 98 | "mutable"; 99 | "new"; 100 | "object"; 101 | "of"; 102 | "open"; 103 | "or"; 104 | "private"; 105 | "rec"; 106 | "sig"; 107 | "struct"; 108 | "then"; 109 | "to"; 110 | "true"; 111 | "try"; 112 | "type"; 113 | "val"; 114 | "virtual"; 115 | "when"; 116 | "while"; 117 | "with" ] 118 | 119 | let is_keyword = 120 | let tbl = Hashtbl.create 100 in 121 | List.iter (fun key -> Hashtbl.add tbl key ()) keywords; 122 | Hashtbl.mem tbl 123 | 124 | let tokenify s = 125 | if is_keyword s then `Keyword s 126 | else `Token s 127 | 128 | let init_lexbuf lexbuf filename = 129 | let pos = lexbuf.lex_curr_p in 130 | lexbuf.lex_curr_p <- { pos with pos_fname = filename } 131 | 132 | 133 | let compare_pos a b = 134 | let c = compare a.pos_lnum b.pos_lnum in 135 | if c <> 0 then c 136 | else compare (a.pos_cnum - a.pos_bol) (b.pos_cnum - b.pos_bol) 137 | 138 | (* Consume the list of annotations *) 139 | let get_annot state cur_pos = 140 | let rec loop () = 141 | match state.annot_tags with 142 | [] -> [] 143 | | ((_, (tag_pos, _)) as tag) :: tl -> 144 | if compare_pos tag_pos cur_pos <= 0 then 145 | (state.annot_tags <- tl; 146 | tag :: loop ()) 147 | else [] in 148 | loop () 149 | 150 | let simple_annot x = 151 | match x with 152 | (`Start typ, (_, info)) -> `Start_annot (info, typ) 153 | | (`Stop, (_, info)) -> `Stop_annot info 154 | 155 | let simple_annots = List.map simple_annot 156 | 157 | (* Add all unclosed tags that may remain *) 158 | let finish_annot state = 159 | state.tokens <- 160 | (List.rev_map simple_annot state.annot_tags) 161 | @ state.tokens; 162 | state.annot_tags <- [] 163 | 164 | let newline state = 165 | let lexbuf = state.lexbuf in 166 | let pos = lexbuf.lex_curr_p in 167 | lexbuf.lex_curr_p <- { pos with 168 | pos_lnum = pos.pos_lnum + 1; 169 | pos_bol = pos.pos_cnum } 170 | 171 | let shift x pos = 172 | { pos with pos_cnum = pos.pos_cnum + x } 173 | 174 | let begin_group state = 175 | state.in_group <- true 176 | 177 | let end_group state = 178 | state.in_group <- false 179 | 180 | let add_token ?(offset = 0) state x = 181 | if x = `Newline then 182 | newline state; 183 | let annot1, annot2 = 184 | if not state.in_group then 185 | let annot1 = 186 | get_annot state (shift offset (lexeme_start_p state.lexbuf)) in 187 | let annot2 = 188 | get_annot state (shift offset (lexeme_end_p state.lexbuf)) in 189 | annot1, annot2 190 | else [], [] in 191 | state.tokens <- (List.rev_append (simple_annots annot2) 192 | (x :: (List.rev_append 193 | (simple_annots annot1) state.tokens))) 194 | 195 | let return_tokens state = 196 | let l = List.rev state.tokens in 197 | let tagged = 198 | List.map (function 199 | `Start_annot _ as x -> (Tag.Start, x) 200 | | `Stop_annot _ as x -> (Tag.Stop, x) 201 | | x -> (Tag.Other, x)) 202 | l in 203 | let annotate b x = 204 | if not b then x 205 | else 206 | match x with 207 | `Start_annot (info, typ) -> 208 | `Start_annot ({ info with Annot.innermost = true }, typ) 209 | | `Stop_annot info -> 210 | `Stop_annot { info with Annot.innermost = true } 211 | | _ -> assert false in 212 | let l = Tag.annotate_innermost annotate (Tag.remove_matches tagged) in 213 | let result = List.map snd l in 214 | result 215 | } 216 | 217 | let upper = ['A'-'Z' '\192'-'\214' '\216'-'\222'] 218 | let lower = ['a'-'z' '\223'-'\246' '\248'-'\255'] 219 | let digit = ['0'-'9'] 220 | let identchar = upper | lower | digit | ['_' '\''] 221 | let hex = ['0'-'9' 'a'-'f' 'A'-'F'] 222 | let oct = ['0'-'7'] 223 | let bin = ['0'-'1'] 224 | 225 | let operator_char = 226 | [ '!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~'] 227 | let infix_symbol = 228 | ['=' '<' '>' '@' '^' '|' '&' '+' '-' '*' '/' '$' '%'] operator_char* 229 | let prefix_symbol = ['!' '?' '~'] operator_char* 230 | 231 | let lident = (lower | '_' identchar) identchar* 232 | let uident = upper identchar* 233 | 234 | let blank = [ ' ' '\t' ] 235 | let space = [ ' ' '\t' '\r' '\n' ] 236 | 237 | rule token state = parse 238 | | "(*" (lident as handler_name)? 239 | { 240 | begin_group state; 241 | Buffer.clear state.buf; 242 | state.depth <- 1; 243 | (match handler_name with 244 | Some name when Plugin.exists name -> 245 | comment true state lexbuf; 246 | let s = Buffer.contents state.buf in 247 | let n = Plugin.count_newlines s in 248 | (for i = 1 to n do newline state done); 249 | add_token state (`Special_comment (name, s)) 250 | | None 251 | | Some _ -> 252 | Buffer.add_string state.buf "(*"; 253 | (match handler_name with 254 | Some name -> Buffer.add_string state.buf name 255 | | None -> ()); 256 | comment false state lexbuf; 257 | Buffer.add_string state.buf "*)"; 258 | add_token state (`Comment (Buffer.contents state.buf)); 259 | ); 260 | end_group state; 261 | token state lexbuf 262 | } 263 | | '"' 264 | { begin_group state; 265 | Buffer.clear state.buf; 266 | Buffer.add_char state.buf '"'; 267 | string state false lexbuf; 268 | add_token state (`String (Buffer.contents state.buf)); 269 | end_group state; 270 | token state lexbuf } 271 | | "<<" 272 | | "<:" lident "<" 273 | { begin_group state; 274 | add_token state (`Construct (lexeme lexbuf)); 275 | Buffer.clear state.buf; 276 | quotation state lexbuf; 277 | add_token ~offset:(-2) state (`Quotation (Buffer.contents state.buf)); 278 | add_token state (`Construct ">>"); 279 | end_group state; 280 | token state lexbuf } 281 | | '`' 282 | | uident 283 | { add_token state (`Construct (lexeme lexbuf)); 284 | token state lexbuf } 285 | | lident 286 | { add_token state (tokenify (lexeme lexbuf)); 287 | token state lexbuf } 288 | 289 | | "!=" | "#" | "&" | "&&" | "(" | ")" | "*" | "+" | "," | "-" 290 | | "-." | "->" | "." | ".. :" | "::" | ":=" | ":>" | ";" | ";;" | "<" 291 | | "<-" | "=" | ">" | ">]" | ">}" | "?" | "??" | "[" | "[<" | "[>" | "[|" 292 | | "]" | "_" | "`" | "{" | "{<" | "|" | "|]" | "}" | "~" 293 | 294 | { add_token state (`Keyword (lexeme lexbuf)); 295 | token state lexbuf } 296 | 297 | | prefix_symbol | infix_symbol 298 | { add_token state (`Token (lexeme lexbuf)); 299 | token state lexbuf } 300 | 301 | | "'\n'" | "'\r\n'" 302 | { List.iter (add_token state) [`String "'"; `Newline; `String "'"]; 303 | token state lexbuf } 304 | | "'\\\n'" | "'\\\r\n'" 305 | { List.iter (add_token state) [`String "'\\"; `Newline; `String "'"]; 306 | token state lexbuf } 307 | | "'" ([^'\'''\\'] | '\\' (_ | digit digit digit | 'x' hex hex)) "'" 308 | { add_token state (`String (lexeme lexbuf)); 309 | token state lexbuf } 310 | 311 | | '\r'? '\n' 312 | { add_token state `Newline; 313 | token state lexbuf } 314 | | '\t' 315 | { add_token state `Tab; 316 | token state lexbuf } 317 | | eof 318 | { finish_annot state; 319 | return_tokens state } 320 | | ' '+ 321 | { add_token state (`Token (lexeme lexbuf)); 322 | token state lexbuf } 323 | 324 | | '-'? (digit (digit | '_')* 325 | | ("0x"| "0X") hex (hex | '_')* 326 | | ("0o"| "0O") oct (oct | '_')* 327 | | ("0b"| "0B") bin (bin | '_')* ) 328 | 329 | | '-'? digit (digit | '_')* ('.' (digit | '_')* )? 330 | (['e' 'E'] ['+' '-']? digit (digit | '_')* )? 331 | | _ 332 | { add_token state (`Token (lexeme lexbuf)); 333 | token state lexbuf } 334 | 335 | and comment special state = parse 336 | | "(*" 337 | { state.depth <- state.depth + 1; 338 | Buffer.add_string state.buf "(*"; 339 | comment special state lexbuf } 340 | | "*)" 341 | { state.depth <- state.depth - 1; 342 | if (state.depth > 0) then ( 343 | Buffer.add_string state.buf "*)"; 344 | comment special state lexbuf 345 | ) 346 | } 347 | | '"' 348 | { Buffer.add_char state.buf '"'; 349 | string state true lexbuf; 350 | comment special state lexbuf } 351 | | eof 352 | { finish_annot state } 353 | | '\r'? '\n' 354 | { if special then ( 355 | Buffer.add_char state.buf '\n'; 356 | comment special state lexbuf 357 | ) 358 | else ( 359 | add_token state (`Comment (Buffer.contents state.buf)); 360 | add_token state `Newline; 361 | Buffer.clear state.buf; 362 | comment special state lexbuf 363 | ) 364 | } 365 | | '\t' 366 | { add_token state (`Comment (Buffer.contents state.buf)); 367 | add_token state `Tab; 368 | Buffer.clear state.buf; 369 | comment special state lexbuf } 370 | | _ 371 | { Buffer.add_string state.buf (lexeme lexbuf); 372 | comment special state lexbuf } 373 | 374 | 375 | and string state comment = parse 376 | | '"' 377 | { Buffer.add_char state.buf '"' } 378 | | "\\\\" 379 | | '\\' '"' 380 | { Buffer.add_string state.buf (lexeme lexbuf); 381 | string state comment lexbuf } 382 | | eof 383 | { finish_annot state } 384 | | '\r'? '\n' 385 | { let s = Buffer.contents state.buf in 386 | add_token state (if comment then `Comment s else `String s); 387 | add_token state `Newline; 388 | Buffer.clear state.buf; 389 | string state comment lexbuf } 390 | | '\t' 391 | { let s = Buffer.contents state.buf in 392 | add_token state (if comment then `Comment s else `String s); 393 | add_token state `Tab; 394 | Buffer.clear state.buf; 395 | string state comment lexbuf } 396 | | _ 397 | { Buffer.add_string state.buf (lexeme lexbuf); 398 | string state comment lexbuf } 399 | 400 | and quotation state = parse 401 | | ">>" { () } 402 | | "\\>>" { Buffer.add_string state.buf "\\>>"; 403 | quotation state lexbuf } 404 | | '\r'? '\n' 405 | { let s = Buffer.contents state.buf in 406 | add_token state (`Quotation s); 407 | add_token state `Newline; 408 | Buffer.clear state.buf; 409 | quotation state lexbuf } 410 | | '\t' 411 | { let s = Buffer.contents state.buf in 412 | add_token state (`Quotation s); 413 | add_token state `Tab; 414 | Buffer.clear state.buf; 415 | quotation state lexbuf } 416 | | _ { Buffer.add_string state.buf (lexeme lexbuf); 417 | quotation state lexbuf } 418 | 419 | { 420 | let parse ?(annot = []) lexbuf = 421 | token (init_state annot lexbuf) lexbuf 422 | 423 | let string ?(filename = "") ?(annot = []) s = 424 | let lexbuf = Lexing.from_string s in 425 | init_lexbuf lexbuf filename; 426 | token (init_state annot lexbuf) lexbuf 427 | 428 | let channel ?(filename = "") ?(annot = []) ic = 429 | let lexbuf = Lexing.from_channel ic in 430 | init_lexbuf lexbuf filename; 431 | token (init_state annot lexbuf) lexbuf 432 | 433 | let file ?annot s = 434 | let ic = open_in s in 435 | let l = channel ~filename:s ?annot ic in 436 | close_in ic; 437 | l 438 | } 439 | -------------------------------------------------------------------------------- /main.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mjambon/caml2html/297a7d2695896a2de8110d2acd4d64c85eb29805/main.ml -------------------------------------------------------------------------------- /man/caml2html.1: -------------------------------------------------------------------------------- 1 | .\" groff -man -Tascii caml2html.1 2 | .\" ========================================================================== 3 | .\" ============= Synopsis =================================================== 4 | .\" ========================================================================== 5 | .TH CAML2HTML 1 "May 2013" CAML2HTML "User Manuals" 6 | .SH NAME 7 | caml2html \- pretty print OCaml in html and latex 8 | .SH SYNOPSIS 9 | .B caml2html \fR[\fIOptions...\fR] \fIfiles\fR... 10 | .\" ========================================================================== 11 | .\" ============= Description ================================================ 12 | .\" ========================================================================== 13 | .SH DESCRIPTION 14 | .B caml2html 15 | pretty prints 16 | .B OCaml 17 | source code as html or LaTex files. The pretty printing uses 18 | colors and adds tool\(hytips with type annotations if the 19 | corresponding .annot file is present. 20 | .\" 21 | .\" ========================================================================== 22 | .P 23 | Without 24 | .I file 25 | arguments, 26 | .B caml2html 27 | reads from standard input. By default it writes to standard output. 28 | .\" 29 | .\" ========================================================================== 30 | .\" ================ Options ================================================= 31 | .\" ========================================================================== 32 | .\" 33 | .SH OPTIONS 34 | .\" ===================== -annotfilter ======================================= 35 | .TP 36 | .B "\-annotfilter {innermost|outermost}" 37 | choose whether innermost or outermost type annotations 38 | should be used (default: innermost) 39 | .\" ===================== -noannot ========================================== 40 | .TP 41 | .B "\-noannot" 42 | do not insert type annotations as read from .annot files (HTML output only) 43 | .\" ===================== -ln =============================================== 44 | .TP 45 | .B "\-ln" 46 | add line number at the beginning of each line 47 | .\" ===================== -hc =============================================== 48 | .TP 49 | .B "\-hc" 50 | comments are treated as raw HTML or LaTeX code (no newlines inside of tags) 51 | .\" ===================== -t ================================================ 52 | .TP 53 | .B "\-t" 54 | add a title to the HTML page 55 | .\" ===================== -body ============================================= 56 | .TP 57 | .B "\-body" 58 | output only document's body, for inclusion into an 59 | existing document (see also \-make\-css and \-make\-latex\-defs) 60 | .\" ===================== -nf =============================================== 61 | .TP 62 | .B "\-nf" 63 | do not add footnotes to the HTML page 64 | .\" ===================== -inhead =========================================== 65 | .TP 66 | .B "\-inhead" 67 | use default styling and place it in the section 68 | of the document (default when applicable) 69 | .\" ===================== -charset ================================= 70 | .TP 71 | .B "\-charset " 72 | specify charset to use (default: iso\-8859\-1) 73 | .\" ===================== -css ============================================== 74 | .TP 75 | .B "\-css" 76 | use separate CSS style file 77 | .I style.css 78 | .\" ===================== -cssurl ====================================== 79 | .TP 80 | .B "\-cssurl " 81 | use 82 | .I URL 83 | as CSS 84 | .\" ===================== -inline =========================================== 85 | .TP 86 | .B "\-inline" 87 | use inline styling (HTML only, default fallback 88 | if \-inhead is not applicable) 89 | .\" ===================== \-ie7 ============================================== 90 | .TP 91 | .B "\-ie7" 92 | drop support for type annotations on Internet Explorer 6 and older 93 | .\" ===================== -notab ============================================ 94 | .TP 95 | .B "\-notab" 96 | do not replace tabs by spaces 97 | .\" ===================== -tab ===================================== 98 | .TP 99 | .B "\-tab " 100 | replace tab by n spaces (default = 8) 101 | .\" ===================== -d ===================================== 102 | .TP 103 | .B "\-d " 104 | generate files in directory dir, rather than in current directory 105 | .\" ===================== -o ====================================== 106 | .TP 107 | .B "\-o " 108 | output file 109 | .\" ===================== -make-css =============================== 110 | .TP 111 | .B "\-make\-css " 112 | create CSS file with default color definitions and exit 113 | .\" ===================== -ext ==================================== 114 | .TP 115 | .B "\-ext " 116 | use the given external command CMD to handle comments that start 117 | with 118 | .I (*NAME\fR. 119 | .I NAME 120 | must be a lowercase identifier. See 121 | .B EXAMPLES 122 | below. 123 | .\" ===================== -latex ============================================ 124 | .TP 125 | .B "\-latex" 126 | output LaTeX code instead of HTML. 127 | .\" ===================== -make-latex-defs ======================== 128 | .TP 129 | .B "\-make\-latex\-defs " 130 | create a file containing the default LaTeX color definitions 131 | and matching highlighting commands, and exit. 132 | \\usepackage{alltt,color} is not included. 133 | .\" ===================== -v ================================================ 134 | .TP 135 | .B "\-v" 136 | print version number to stdout and exit 137 | .\" ===================== -help Display this list of options ================ 138 | .TP 139 | .B "\-help | \-\-help" 140 | Display options and exit. 141 | .\" 142 | .\" ========================================================================== 143 | .\" ================ Examples ================================================ 144 | .\" ========================================================================== 145 | .\" 146 | .SH EXAMPLES 147 | .\" 148 | Process many files into a single file: 149 | .P 150 | .RS 151 | caml2html \-o result.html *.mli *.ml 152 | .RE 153 | .P 154 | Process many files, and create one HTML page for each file: 155 | .P 156 | .RS 157 | caml2html *.ml 158 | .RE 159 | .P 160 | You can use HTML in the comments of the source file, for 161 | instance, to insert hyperlinks: 162 | .P 163 | .RS 164 | (* This is file1.ml. 165 | This is a link to file2.ml. *) 166 | .RE 167 | .P 168 | Note, that one HTML tag cannot span over several lines, and that 169 | the ordinary characters <, > and & must be written as <, > and 170 | &. 171 | .\" 172 | .\" ========================================================================== 173 | .P 174 | .B Custom comment handlers 175 | To implement an include directive for comments, use 176 | .P 177 | .RS 178 | caml2html \-ext "include: xargs cat" example.ml 179 | .RE 180 | .P 181 | Then 182 | .P 183 | .RS 184 | (*include i.html *) 185 | let f x = 2 * x + 1 186 | .RE 187 | .P 188 | produces 189 | .P 190 | .RS 191 | ... contens of i.html ... 192 | let f x = 2 * x + 1 193 | .RE 194 | .P 195 | as result. 196 | .\" 197 | .\" ========================================================================== 198 | .\" ================ SEE ALSO ================================================ 199 | .\" ========================================================================== 200 | .\" 201 | .SH SEE ALSO 202 | .TP 203 | The \fBcaml2html\fR web page, 204 | \fIhttp://mjambon.com/caml2html.html\fR 205 | .TP 206 | Some more examples are on 207 | .I /usr/share/doc/caml2html/caml2html.html 208 | .\" 209 | .\" ========================================================================== 210 | .\" ================ Author ================================================== 211 | .\" ========================================================================== 212 | .\" 213 | .SH AUTHOR 214 | This manual page was written by Sylvain Le Gall 215 | and Hendrik Tews , 216 | specifically for the Debian project (and may be used by others). 217 | 218 | 219 | -------------------------------------------------------------------------------- /output.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mjambon/caml2html/297a7d2695896a2de8110d2acd4d64c85eb29805/output.ml -------------------------------------------------------------------------------- /output.mli: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2004 Martin Jambon 3 | 4 | This module produces HTML code for the presentation of OCaml programs 5 | (.ml .mli .mll .mly). 6 | 7 | This file is distributed under the terms of the GNU Public License 8 | http://www.gnu.org/licenses/gpl.txt 9 | *) 10 | 11 | val version : string 12 | (** Version of caml2html. For compatibility with older versions. 13 | Use [Version.version] instead, which returns only the version code, 14 | without the "caml2html " prefix. *) 15 | 16 | type class_definition = (string list * (string * string) list) 17 | 18 | val default_default_style : class_definition list 19 | 20 | val default_style : string 21 | 22 | val key_color1 : string option 23 | val key_color2 : string option 24 | val key_color3 : string option 25 | val key_color4 : string option 26 | val key_color5 : string option 27 | val construct_color : string option * string option * string 28 | val comment_color : string option * string option * string 29 | val string_color : string option * string option * string 30 | val alpha_keyword_color : string option * string option * string 31 | val nonalpha_keyword_color : string option * string option * string 32 | 33 | val default_keyword_color_list : 34 | (string * (string option * string option * string)) list 35 | val default_keyword_colors : 36 | (string, string option * string option * string) Hashtbl.t 37 | val all_colors : (string option * string option * string) list 38 | (** colors which are used for the predefined style. 39 | This is a list of couples (optional color specification, CSS class). *) 40 | 41 | val make_css : 42 | ?default: class_definition list -> 43 | ?colors:(string option * string option * string) list -> string -> unit 44 | (** make a CSS file from the given colors *) 45 | 46 | type style = [ `Inline | `Inhead of string | `Url of string ] 47 | 48 | type param = { 49 | line_numbers : bool; 50 | title : bool; 51 | body_only : bool; 52 | tab_size : int; 53 | footnote : bool; 54 | style : style; 55 | html_comments : bool; 56 | charset : string; 57 | annot_filter : Annot.filter; 58 | no_annot : bool; 59 | ie7 : bool; 60 | } 61 | (** the type of the options for making the HTML document *) 62 | 63 | val default_param : param 64 | 65 | val ocaml : 66 | ?nbsp:bool -> 67 | ?keyword_colors:(string, string option * string option * string) Hashtbl.t -> 68 | ?param:param -> 69 | Buffer.t -> 70 | Input.token list -> unit 71 | (** [ocaml buf l] formats the list of tokens [l] into some HTML code 72 | which should be placed in a \ or \ region, 73 | and adds the result the given buffer [buf]. 74 | Option [nbsp] tells if the spaces must be converted into " " or not 75 | (required in \ regions but not in \; default is false). *) 76 | 77 | val ocamlcode : 78 | ?annot:Annot.tag list -> 79 | ?keyword_colors:(string, string option * string option * string) Hashtbl.t -> 80 | ?param:param -> ?tag_open:string -> ?tag_close:string -> string -> string 81 | (** [ocamlcode s1 s2] parses [s1] and formats the result as a HTML string 82 | enclosed between \ and \ unless specified otherwise. *) 83 | 84 | val ocamlpre : 85 | ?annot:Annot.tag list -> 86 | ?keyword_colors:(string, string option * string option * string) Hashtbl.t -> 87 | ?param:param -> ?tag_open:string -> ?tag_close:string -> string -> string 88 | (** [ocamlcode s1 s2] parses [s1] and formats the result as a HTML string 89 | enclosed between \ and \ unless specified otherwise. *) 90 | 91 | val ocaml_file : 92 | ?filename:string -> 93 | ?keyword_colors:(string, string option * string option * string) Hashtbl.t -> 94 | param:param -> 95 | Buffer.t -> 96 | Input.token list -> unit 97 | (** [ocaml_file buf tokens] makes HTML code that represents one source file 98 | of OCaml code. The name of the file is added as title, 99 | depending on the parameters and is specified with the [filename] option. 100 | *) 101 | 102 | val begin_document : ?param:param -> Buffer.t -> string list -> unit 103 | val end_document : ?param:param -> Buffer.t -> unit 104 | 105 | val handle_file : 106 | ?keyword_colors:(string, string option * string option * string) Hashtbl.t -> 107 | ?param:param -> Buffer.t -> string -> unit 108 | (** [handle_file buf srcfile] parse the given file [srcfile] 109 | and puts the HTML into [buf]. *) 110 | 111 | val save_file : ?dir:string -> Buffer.t -> string -> unit 112 | (** [save_file buf file] just saves the contents of buffer [buf] 113 | in the given [file]. *) 114 | 115 | val ocaml_document : 116 | ?dir:string -> 117 | ?keyword_colors:(string, string option * string option * string) Hashtbl.t -> 118 | ?param:param -> string list -> string -> unit 119 | (** [ocaml_document files file] parses the given OCaml [files] 120 | and make one complete HTML document that shows the contents of 121 | these files. *) 122 | -------------------------------------------------------------------------------- /output_latex.ml: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/mjambon/caml2html/297a7d2695896a2de8110d2acd4d64c85eb29805/output_latex.ml -------------------------------------------------------------------------------- /output_latex.mli: -------------------------------------------------------------------------------- 1 | (* 2 | Copyright 2004, 2010 Martin Jambon 3 | 4 | This module produces HTML code for the presentation of OCaml programs 5 | (.ml .mli .mll .mly). 6 | 7 | This file is distributed under the terms of the GNU Public License 8 | http://www.gnu.org/licenses/gpl.txt 9 | *) 10 | 11 | (* $Id$ *) 12 | 13 | type class_definition = (string list * (string * string) list) 14 | 15 | val default_style : string 16 | 17 | val key_color1 : string option 18 | val key_color2 : string option 19 | val key_color3 : string option 20 | val key_color4 : string option 21 | val key_color5 : string option 22 | val construct_color : string option * string 23 | val comment_color : string option * string 24 | val string_color : string option * string 25 | val alpha_keyword_color : string option * string 26 | val nonalpha_keyword_color : string option * string 27 | 28 | val default_keyword_color_list : 29 | (string * (string option * string)) list 30 | val default_keyword_colors : 31 | (string, string option * string) Hashtbl.t 32 | val all_colors : (string option * string) list 33 | (** colors which are used for the predefined style. 34 | This is a list of pairs (optional color specification, CSS class). *) 35 | 36 | val make_defs_file : 37 | ?colors:(string option * string) list -> string -> unit 38 | (** Dump color definitions and matching highlighting commands into a file. *) 39 | 40 | type param = { 41 | line_numbers : bool; 42 | title : bool; 43 | body_only : bool; 44 | tab_size : int; 45 | latex_comments : bool; 46 | defs : string; 47 | } 48 | (** the type of the options for making the HTML document *) 49 | 50 | val default_param : param 51 | 52 | val ocaml : 53 | ?keyword_colors:(string, string option * string) Hashtbl.t -> 54 | ?param:param -> 55 | Buffer.t -> 56 | Input.token list -> unit 57 | (** [ocaml buf l] formats the list of tokens [l] into some LaTeX code 58 | which should be placed within the alltt environment, 59 | and adds the result the given buffer [buf]. *) 60 | 61 | val ocaml_file : 62 | ?filename:string -> 63 | ?keyword_colors:(string, string option * string) Hashtbl.t -> 64 | param:param -> 65 | Buffer.t -> 66 | Input.token list -> unit 67 | (** [ocaml_file buf tokens] makes LaTeX code that represents one source file 68 | of OCaml code. The name of the file is added as title, 69 | depending on the parameters and is specified with the [filename] option. 70 | *) 71 | 72 | val begin_document : ?param:param -> Buffer.t -> string list -> unit 73 | val end_document : ?param:param -> Buffer.t -> unit 74 | 75 | val handle_file : 76 | ?keyword_colors:(string, string option * string) Hashtbl.t -> 77 | ?param:param -> Buffer.t -> string -> unit 78 | (** [handle_file buf srcfile] parse the given file [srcfile] 79 | and puts the HTML into [buf]. *) 80 | 81 | val save_file : ?dir:string -> Buffer.t -> string -> unit 82 | (** [save_file buf file] just saves the contents of buffer [buf] 83 | in the given [file]. *) 84 | 85 | val ocaml_document : 86 | ?dir:string -> 87 | ?keyword_colors:(string, string option * string) Hashtbl.t -> 88 | ?param:param -> string list -> string -> unit 89 | (** [ocaml_document files file] parses the given OCaml [files] 90 | and make one complete HTML document that shows the contents of 91 | these files. *) 92 | -------------------------------------------------------------------------------- /plugin.ml: -------------------------------------------------------------------------------- 1 | (* $Id$ *) 2 | 3 | open Printf 4 | 5 | type handler = 6 | [ `Command of string 7 | | `Function of (string -> string option) ] 8 | 9 | let plugins = Hashtbl.create 20 10 | 11 | let add = Hashtbl.replace plugins 12 | let remove = Hashtbl.remove plugins 13 | let exists = Hashtbl.mem plugins 14 | let find = Hashtbl.find plugins 15 | 16 | 17 | let count_newlines s = 18 | let n = ref 0 in 19 | String.iter ( 20 | function 21 | '\n' -> incr n 22 | | _ -> () 23 | ) s; 24 | !n 25 | 26 | let expand name s = 27 | let h = 28 | try find name 29 | with Not_found -> 30 | failwith (sprintf "Plugin %s doesn't exist." name) 31 | in 32 | match h with 33 | `Function f -> f s 34 | | `Command cmd -> 35 | let p = Unix.open_process cmd in 36 | let ic, oc = p in 37 | output_string oc s; 38 | close_out oc; 39 | let buf = Buffer.create 1024 in 40 | try 41 | while true do 42 | Buffer.add_string buf (input_line ic); 43 | Buffer.add_char buf '\n' 44 | done; 45 | assert false 46 | with End_of_file -> 47 | match Unix.close_process p with 48 | Unix.WEXITED 0 -> Some (Buffer.contents buf) 49 | | _ -> None 50 | 51 | 52 | let html_handler = 53 | `Function (fun s -> Some s) 54 | 55 | let _ = 56 | add "html" html_handler 57 | 58 | 59 | let register_command s = 60 | try 61 | let i = String.index s ':' in 62 | let name = String.sub s 0 i in 63 | let cmd = String.sub s (i+1) (String.length s - i - 1) in 64 | if name = "" || cmd = "" then 65 | raise Not_found 66 | else 67 | add name (`Command cmd) 68 | with Not_found -> 69 | failwith (sprintf "Cannot register %S: wrong syntax" s) 70 | -------------------------------------------------------------------------------- /plugin.mli: -------------------------------------------------------------------------------- 1 | (* $Id$ *) 2 | 3 | type handler = 4 | [ `Command of string (* External command *) 5 | | `Function of (string -> string option) (* Function *) ] 6 | (** Custom comment handler. *) 7 | 8 | val add : string -> handler -> unit 9 | (** Add or replace handler. *) 10 | 11 | val remove : string -> unit 12 | (** Remove handler if it exists. *) 13 | 14 | val exists : string -> bool 15 | (** Test whether such handler exists. *) 16 | 17 | val find : string -> handler 18 | (** Find handler or raise [Not_found]. *) 19 | 20 | 21 | val count_newlines : string -> int 22 | (** Count the number of newline characters in a string. *) 23 | 24 | val expand : string -> string -> string option 25 | (** [expand handler_name s] find the handler [handler_name] 26 | and apply it to the input string [s]. 27 | If the handler is an external command, the result is [None] 28 | if and only if the process exits with a non-zero status. 29 | If the handler is a function, the behavior corresponds to 30 | the behavior of the function itself and any exception is propagated. 31 | *) 32 | 33 | val register_command : string -> unit 34 | (** Parse and register a handler defined as "name:command". *) 35 | -------------------------------------------------------------------------------- /style.css: -------------------------------------------------------------------------------- 1 | .Cannot:hover { background-color: #b4eeb4; } 2 | .Cbar, 3 | .Cdo, 4 | .Cdone, 5 | .Cdownto, 6 | .Celse, 7 | .Cfor, 8 | .Cif, 9 | .Clazy, 10 | .Cmatch, 11 | .Cnew, 12 | .Cor, 13 | .Cthen, 14 | .Cto, 15 | .Ctry, 16 | .Cwhen, 17 | .Cwhile, 18 | .Cwith { color: #77aaaa; } 19 | .Cassert, 20 | .Cinclude, 21 | .Copen { color: #cc9900; } 22 | .Cstring { color: #aa4444; } 23 | .Cand, 24 | .Cas, 25 | .Cclass, 26 | .Cconstraint, 27 | .Cexception, 28 | .Cexternal, 29 | .Cfun, 30 | .Cfunction, 31 | .Cfunctor, 32 | .Cin, 33 | .Cinherit, 34 | .Cinitializer, 35 | .Clet, 36 | .Cmethod, 37 | .Cmodule, 38 | .Cmutable, 39 | .Cof, 40 | .Cprivate, 41 | .Crec, 42 | .Ctype, 43 | .Cval, 44 | .Cvirtual { color: green; } 45 | .Cbackground { background-color: white; } 46 | .Craise { color: red; } 47 | .Cconstructor { color: #0033cc; } 48 | .Ccomment { color: #990000; } 49 | .Calphakeyword, 50 | .Casr, 51 | .Cland, 52 | .Clor, 53 | .Clsl, 54 | .Clsr, 55 | .Clxor, 56 | .Cmod { color: #808080; } 57 | .Clinenum { color: black; background-color: silver; } 58 | .Cbegin, 59 | .Cend, 60 | .Cobject, 61 | .Csig, 62 | .Cstruct { color: #990099; } 63 | .Cfalse, 64 | .Cnonalphakeyword, 65 | .Cquotation, 66 | .Ctrue { } 67 | -------------------------------------------------------------------------------- /tag.ml: -------------------------------------------------------------------------------- 1 | (* $Id$ *) 2 | (* Various operations on lists of elements (Other) mixed with 3 | Start and Stop tags *) 4 | 5 | 6 | (* The type of elements *) 7 | type kind = Start | Stop | Other 8 | 9 | (* Recursively remove consecutive start/stop pairs *) 10 | let rec remove_matches = function 11 | (Start, _) as start :: l -> 12 | (match remove_matches l with 13 | (Stop, _) :: rest -> rest 14 | | rest -> start :: rest) 15 | | (Stop, _) as stop :: l -> stop :: remove_matches l 16 | | (Other, _) as x :: l -> x :: remove_matches l 17 | | [] -> [] 18 | 19 | (* Annotate innermost start/stop pairs *) 20 | let rec annotate_innermost f = function 21 | (Start, a) :: l -> 22 | let other, next_stop = find_stop f [] l in 23 | (match next_stop with 24 | (Stop, b) :: rest -> 25 | (Start, f true a) :: other @ (Stop, f true b) :: 26 | annotate_innermost f rest 27 | | (Start, _) :: _ -> other @ annotate_innermost f next_stop 28 | | (Other, _) :: _ -> assert false 29 | | [] -> other) 30 | | (tag, x) :: l -> (tag, f false x) :: annotate_innermost f l 31 | | [] -> [] 32 | 33 | and find_stop f accu = function 34 | (Other, x) :: l -> find_stop f ((Other, f false x) :: accu) l 35 | | l -> (List.rev accu), l 36 | 37 | (* 38 | let start x = (Start, x);; 39 | let stop x = (Stop, x);; 40 | let other x = (Other, x);; 41 | let annotate b x = (x, b);; 42 | let l1, l2 = 43 | [ stop 1; stop 2; start 3; start 4; start 5; stop 5; start 6 ], 44 | [ stop 6; start 7; stop 7; stop 4; stop 3; start 8; stop 8; start 9 ];; 45 | let l = remove_matches (l1 @ [other 10] @ l2);; 46 | annotate_innermost annotate l;; 47 | *) 48 | -------------------------------------------------------------------------------- /test.ml: -------------------------------------------------------------------------------- 1 | (* The type of elements *) 2 | type kind = Start | Stop | Other 3 | 4 | (* Recursively remove consecutive start/stop pairs *) 5 | let rec remove_matches = function 6 | (Start, _) as start :: l -> 7 | (match remove_matches l with 8 | (Stop, _) :: rest -> rest 9 | | rest -> start :: rest) 10 | | (Stop, _) as stop :: l -> stop :: remove_matches l 11 | | (Other, _) as x :: l -> x :: remove_matches l 12 | | [] -> [] 13 | 14 | (* Annotate innermost start/stop pairs *) 15 | let rec annotate_innermost f = function 16 | (Start, a) :: l -> 17 | let other, next_stop = find_stop f [] l in 18 | (match next_stop with 19 | (Stop, b) :: rest -> 20 | (Start, f true a) :: other @ (Stop, f true b) :: 21 | annotate_innermost f rest 22 | | (Start, _) :: _ -> other @ annotate_innermost f next_stop 23 | | (Other, _) :: _ -> assert false 24 | | [] -> other) 25 | | (tag, x) :: l -> (tag, f false x) :: annotate_innermost f l 26 | | [] -> [] 27 | 28 | and find_stop f accu = function 29 | (Other, x) :: l -> find_stop f ((Other, f false x) :: accu) l 30 | | l -> (List.rev accu), l 31 | 32 | 33 | let start x = (Start, x);; 34 | let stop x = (Stop, x);; 35 | let other x = (Other, x);; 36 | let annotate b x = (x, b);; 37 | let l1, l2 = 38 | [ stop 1; stop 2; start 3; start 4; start 5; stop 5; start 6 ], 39 | [ stop 6; start 7; stop 7; stop 4; stop 3; start 8; stop 8; start 9 ];; 40 | let l = remove_matches (l1 @ [other 10] @ l2);; 41 | annotate_innermost annotate l;; 42 | -------------------------------------------------------------------------------- /version.ml.mlx: -------------------------------------------------------------------------------- 1 | let version = "##= Sys.getenv "VERSION" ##" 2 | --------------------------------------------------------------------------------