├── .dir-locals.el ├── .gitignore ├── LICENSE ├── ast_analysis.ml ├── ast_transformer.ml ├── ast_zipper.ml ├── changelog.md ├── dune ├── dune-project ├── extras ├── readme.md └── snippets │ ├── assert │ ├── begin │ ├── for │ ├── fun │ ├── guard │ ├── ifelse │ ├── ifthen │ ├── let-in │ ├── match │ ├── printf │ ├── sexp │ ├── signature │ ├── sprintf │ ├── struct │ ├── try │ └── while ├── generic_types.ml ├── gopcaml-mode.el ├── gopcaml-mode.opam ├── gopcaml-multiple-cursors.el ├── gopcaml-smartparens.el ├── gopcaml.ml ├── gopcaml_state.ml ├── images ├── gopcaml_auto_let_binding_example.gif ├── gopcaml_extraction_expressions.gif ├── gopcaml_mark_sexp.gif ├── gopcaml_move_expression_example.gif ├── gopcaml_move_function_example.gif ├── gopcaml_move_to_defun_example.gif ├── gopcaml_move_to_nearest_letdef.gif ├── gopcaml_move_to_parameter.gif └── gopcaml_move_to_type_hole.gif ├── logging.ml ├── logging.mli ├── parser ├── 408 │ └── generic_parser.ml ├── 409 │ └── generic_parser.ml ├── 410 │ └── generic_parser.ml ├── 411 │ └── generic_parser.ml ├── 412 │ └── generic_parser.ml ├── 413 │ └── generic_parser.ml ├── 414 │ └── generic_parser.ml ├── dune └── generic_parser.mli ├── preprocessing.ml ├── readme.md ├── text_region.ml ├── text_region.mli ├── todo.org └── todo.org_archive /.dir-locals.el: -------------------------------------------------------------------------------- 1 | ;;; Directory Local Variables 2 | ;;; For more information see (info "(emacs) Directory Variables") 3 | 4 | ((nil 5 | ;; ensure that the init-file has been setup correctly 6 | (eval if (or (not (boundp 'gopcaml-dev-mode)) (not gopcaml-dev-mode)) 7 | (error "Please ensure that your init file is setup as in the README.")) 8 | ;; add project to load directory 9 | (eval 10 | when (and (current-buffer) (buffer-file-name (current-buffer))) 11 | (add-to-list 'load-path 12 | (expand-file-name 13 | (file-name-directory 14 | (buffer-file-name 15 | (current-buffer))))) 16 | ;; setup gopcaml-mode to autoload 17 | (autoload 'gopcaml-mode 18 | (expand-file-name 19 | "gopcaml-mode" 20 | (file-name-directory (buffer-file-name (current-buffer)))) 21 | nil t nil) 22 | ) 23 | ;; global variable to track whether dev mode has been loaded for specific files 24 | (eval setq gopcaml-dev-mode-filemap 25 | (if (not (boundp 'gopcaml-dev-mode-filemap)) 26 | (make-hash-table) gopcaml-dev-mode-filemap)) 27 | ;; if the current file has not be loaded into gopcaml-mode 28 | (eval if 29 | (not (gethash (buffer-file-name (current-buffer)) 30 | gopcaml-dev-mode-filemap nil)) 31 | ;; and it is a ml file 32 | (when (and (current-buffer) 33 | (buffer-file-name (current-buffer)) 34 | (file-name-extension (buffer-file-name (current-buffer))) 35 | (string-match "\\(ml\\|mli\\)" 36 | (file-name-extension (buffer-file-name (current-buffer))))) 37 | ;; then start gopcaml-mode 38 | ;; (setting gopcaml-dev-mode-file to the name of this file) 39 | (setq 40 | gopcaml-dev-mode-file 41 | (buffer-file-name (current-buffer))) 42 | ;; gopcaml-mode will then initialize for this buffer and then record 43 | ;; that the file specified by gopcaml-dev-mode-file is not being used 44 | (gopcaml-mode))) 45 | ;; otherwise for safety just clear to gopcaml-dev-mode-file variable 46 | (setq gopcaml-dev-mode-file nil)) 47 | )) 48 | 49 | 50 | 51 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | _build/* 2 | .merlin 3 | **/*.merlin 4 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | Preamble 9 | 10 | The GNU General Public License is a free, copyleft license for 11 | software and other kinds of works. 12 | 13 | The licenses for most software and other practical works are designed 14 | to take away your freedom to share and change the works. By contrast, 15 | the GNU General Public License is intended to guarantee your freedom to 16 | share and change all versions of a program--to make sure it remains free 17 | software for all its users. We, the Free Software Foundation, use the 18 | GNU General Public License for most of our software; it applies also to 19 | any other work released this way by its authors. You can apply it to 20 | your programs, too. 21 | 22 | When we speak of free software, we are referring to freedom, not 23 | price. Our General Public Licenses are designed to make sure that you 24 | have the freedom to distribute copies of free software (and charge for 25 | them if you wish), that you receive source code or can get it if you 26 | want it, that you can change the software or use pieces of it in new 27 | free programs, and that you know you can do these things. 28 | 29 | To protect your rights, we need to prevent others from denying you 30 | these rights or asking you to surrender the rights. Therefore, you have 31 | certain responsibilities if you distribute copies of the software, or if 32 | you modify it: responsibilities to respect the freedom of others. 33 | 34 | For example, if you distribute copies of such a program, whether 35 | gratis or for a fee, you must pass on to the recipients the same 36 | freedoms that you received. You must make sure that they, too, receive 37 | or can get the source code. And you must show them these terms so they 38 | know their rights. 39 | 40 | Developers that use the GNU GPL protect your rights with two steps: 41 | (1) assert copyright on the software, and (2) offer you this License 42 | giving you legal permission to copy, distribute and/or modify it. 43 | 44 | For the developers' and authors' protection, the GPL clearly explains 45 | that there is no warranty for this free software. For both users' and 46 | authors' sake, the GPL requires that modified versions be marked as 47 | changed, so that their problems will not be attributed erroneously to 48 | authors of previous versions. 49 | 50 | Some devices are designed to deny users access to install or run 51 | modified versions of the software inside them, although the manufacturer 52 | can do so. This is fundamentally incompatible with the aim of 53 | protecting users' freedom to change the software. The systematic 54 | pattern of such abuse occurs in the area of products for individuals to 55 | use, which is precisely where it is most unacceptable. Therefore, we 56 | have designed this version of the GPL to prohibit the practice for those 57 | products. If such problems arise substantially in other domains, we 58 | stand ready to extend this provision to those domains in future versions 59 | of the GPL, as needed to protect the freedom of users. 60 | 61 | Finally, every program is threatened constantly by software patents. 62 | States should not allow patents to restrict development and use of 63 | software on general-purpose computers, but in those that do, we wish to 64 | avoid the special danger that patents applied to a free program could 65 | make it effectively proprietary. To prevent this, the GPL assures that 66 | patents cannot be used to render the program non-free. 67 | 68 | The precise terms and conditions for copying, distribution and 69 | modification follow. 70 | 71 | TERMS AND CONDITIONS 72 | 73 | 0. Definitions. 74 | 75 | "This License" refers to version 3 of the GNU General Public License. 76 | 77 | "Copyright" also means copyright-like laws that apply to other kinds of 78 | works, such as semiconductor masks. 79 | 80 | "The Program" refers to any copyrightable work licensed under this 81 | License. Each licensee is addressed as "you". "Licensees" and 82 | "recipients" may be individuals or organizations. 83 | 84 | To "modify" a work means to copy from or adapt all or part of the work 85 | in a fashion requiring copyright permission, other than the making of an 86 | exact copy. The resulting work is called a "modified version" of the 87 | earlier work or a work "based on" the earlier work. 88 | 89 | A "covered work" means either the unmodified Program or a work based 90 | on the Program. 91 | 92 | To "propagate" a work means to do anything with it that, without 93 | permission, would make you directly or secondarily liable for 94 | infringement under applicable copyright law, except executing it on a 95 | computer or modifying a private copy. Propagation includes copying, 96 | distribution (with or without modification), making available to the 97 | public, and in some countries other activities as well. 98 | 99 | To "convey" a work means any kind of propagation that enables other 100 | parties to make or receive copies. Mere interaction with a user through 101 | a computer network, with no transfer of a copy, is not conveying. 102 | 103 | An interactive user interface displays "Appropriate Legal Notices" 104 | to the extent that it includes a convenient and prominently visible 105 | feature that (1) displays an appropriate copyright notice, and (2) 106 | tells the user that there is no warranty for the work (except to the 107 | extent that warranties are provided), that licensees may convey the 108 | work under this License, and how to view a copy of this License. If 109 | the interface presents a list of user commands or options, such as a 110 | menu, a prominent item in the list meets this criterion. 111 | 112 | 1. Source Code. 113 | 114 | The "source code" for a work means the preferred form of the work 115 | for making modifications to it. "Object code" means any non-source 116 | form of a work. 117 | 118 | A "Standard Interface" means an interface that either is an official 119 | standard defined by a recognized standards body, or, in the case of 120 | interfaces specified for a particular programming language, one that 121 | is widely used among developers working in that language. 122 | 123 | The "System Libraries" of an executable work include anything, other 124 | than the work as a whole, that (a) is included in the normal form of 125 | packaging a Major Component, but which is not part of that Major 126 | Component, and (b) serves only to enable use of the work with that 127 | Major Component, or to implement a Standard Interface for which an 128 | implementation is available to the public in source code form. A 129 | "Major Component", in this context, means a major essential component 130 | (kernel, window system, and so on) of the specific operating system 131 | (if any) on which the executable work runs, or a compiler used to 132 | produce the work, or an object code interpreter used to run it. 133 | 134 | The "Corresponding Source" for a work in object code form means all 135 | the source code needed to generate, install, and (for an executable 136 | work) run the object code and to modify the work, including scripts to 137 | control those activities. However, it does not include the work's 138 | System Libraries, or general-purpose tools or generally available free 139 | programs which are used unmodified in performing those activities but 140 | which are not part of the work. For example, Corresponding Source 141 | includes interface definition files associated with source files for 142 | the work, and the source code for shared libraries and dynamically 143 | linked subprograms that the work is specifically designed to require, 144 | such as by intimate data communication or control flow between those 145 | subprograms and other parts of the work. 146 | 147 | The Corresponding Source need not include anything that users 148 | can regenerate automatically from other parts of the Corresponding 149 | Source. 150 | 151 | The Corresponding Source for a work in source code form is that 152 | same work. 153 | 154 | 2. Basic Permissions. 155 | 156 | All rights granted under this License are granted for the term of 157 | copyright on the Program, and are irrevocable provided the stated 158 | conditions are met. This License explicitly affirms your unlimited 159 | permission to run the unmodified Program. The output from running a 160 | covered work is covered by this License only if the output, given its 161 | content, constitutes a covered work. This License acknowledges your 162 | rights of fair use or other equivalent, as provided by copyright law. 163 | 164 | You may make, run and propagate covered works that you do not 165 | convey, without conditions so long as your license otherwise remains 166 | in force. You may convey covered works to others for the sole purpose 167 | of having them make modifications exclusively for you, or provide you 168 | with facilities for running those works, provided that you comply with 169 | the terms of this License in conveying all material for which you do 170 | not control copyright. Those thus making or running the covered works 171 | for you must do so exclusively on your behalf, under your direction 172 | and control, on terms that prohibit them from making any copies of 173 | your copyrighted material outside their relationship with you. 174 | 175 | Conveying under any other circumstances is permitted solely under 176 | the conditions stated below. Sublicensing is not allowed; section 10 177 | makes it unnecessary. 178 | 179 | 3. Protecting Users' Legal Rights From Anti-Circumvention Law. 180 | 181 | No covered work shall be deemed part of an effective technological 182 | measure under any applicable law fulfilling obligations under article 183 | 11 of the WIPO copyright treaty adopted on 20 December 1996, or 184 | similar laws prohibiting or restricting circumvention of such 185 | measures. 186 | 187 | When you convey a covered work, you waive any legal power to forbid 188 | circumvention of technological measures to the extent such circumvention 189 | is effected by exercising rights under this License with respect to 190 | the covered work, and you disclaim any intention to limit operation or 191 | modification of the work as a means of enforcing, against the work's 192 | users, your or third parties' legal rights to forbid circumvention of 193 | technological measures. 194 | 195 | 4. Conveying Verbatim Copies. 196 | 197 | You may convey verbatim copies of the Program's source code as you 198 | receive it, in any medium, provided that you conspicuously and 199 | appropriately publish on each copy an appropriate copyright notice; 200 | keep intact all notices stating that this License and any 201 | non-permissive terms added in accord with section 7 apply to the code; 202 | keep intact all notices of the absence of any warranty; and give all 203 | recipients a copy of this License along with the Program. 204 | 205 | You may charge any price or no price for each copy that you convey, 206 | and you may offer support or warranty protection for a fee. 207 | 208 | 5. Conveying Modified Source Versions. 209 | 210 | You may convey a work based on the Program, or the modifications to 211 | produce it from the Program, in the form of source code under the 212 | terms of section 4, provided that you also meet all of these conditions: 213 | 214 | a) The work must carry prominent notices stating that you modified 215 | it, and giving a relevant date. 216 | 217 | b) The work must carry prominent notices stating that it is 218 | released under this License and any conditions added under section 219 | 7. This requirement modifies the requirement in section 4 to 220 | "keep intact all notices". 221 | 222 | c) You must license the entire work, as a whole, under this 223 | License to anyone who comes into possession of a copy. This 224 | License will therefore apply, along with any applicable section 7 225 | additional terms, to the whole of the work, and all its parts, 226 | regardless of how they are packaged. This License gives no 227 | permission to license the work in any other way, but it does not 228 | invalidate such permission if you have separately received it. 229 | 230 | d) If the work has interactive user interfaces, each must display 231 | Appropriate Legal Notices; however, if the Program has interactive 232 | interfaces that do not display Appropriate Legal Notices, your 233 | work need not make them do so. 234 | 235 | A compilation of a covered work with other separate and independent 236 | works, which are not by their nature extensions of the covered work, 237 | and which are not combined with it such as to form a larger program, 238 | in or on a volume of a storage or distribution medium, is called an 239 | "aggregate" if the compilation and its resulting copyright are not 240 | used to limit the access or legal rights of the compilation's users 241 | beyond what the individual works permit. Inclusion of a covered work 242 | in an aggregate does not cause this License to apply to the other 243 | parts of the aggregate. 244 | 245 | 6. Conveying Non-Source Forms. 246 | 247 | You may convey a covered work in object code form under the terms 248 | of sections 4 and 5, provided that you also convey the 249 | machine-readable Corresponding Source under the terms of this License, 250 | in one of these ways: 251 | 252 | a) Convey the object code in, or embodied in, a physical product 253 | (including a physical distribution medium), accompanied by the 254 | Corresponding Source fixed on a durable physical medium 255 | customarily used for software interchange. 256 | 257 | b) Convey the object code in, or embodied in, a physical product 258 | (including a physical distribution medium), accompanied by a 259 | written offer, valid for at least three years and valid for as 260 | long as you offer spare parts or customer support for that product 261 | model, to give anyone who possesses the object code either (1) a 262 | copy of the Corresponding Source for all the software in the 263 | product that is covered by this License, on a durable physical 264 | medium customarily used for software interchange, for a price no 265 | more than your reasonable cost of physically performing this 266 | conveying of source, or (2) access to copy the 267 | Corresponding Source from a network server at no charge. 268 | 269 | c) Convey individual copies of the object code with a copy of the 270 | written offer to provide the Corresponding Source. This 271 | alternative is allowed only occasionally and noncommercially, and 272 | only if you received the object code with such an offer, in accord 273 | with subsection 6b. 274 | 275 | d) Convey the object code by offering access from a designated 276 | place (gratis or for a charge), and offer equivalent access to the 277 | Corresponding Source in the same way through the same place at no 278 | further charge. You need not require recipients to copy the 279 | Corresponding Source along with the object code. If the place to 280 | copy the object code is a network server, the Corresponding Source 281 | may be on a different server (operated by you or a third party) 282 | that supports equivalent copying facilities, provided you maintain 283 | clear directions next to the object code saying where to find the 284 | Corresponding Source. Regardless of what server hosts the 285 | Corresponding Source, you remain obligated to ensure that it is 286 | available for as long as needed to satisfy these requirements. 287 | 288 | e) Convey the object code using peer-to-peer transmission, provided 289 | you inform other peers where the object code and Corresponding 290 | Source of the work are being offered to the general public at no 291 | charge under subsection 6d. 292 | 293 | A separable portion of the object code, whose source code is excluded 294 | from the Corresponding Source as a System Library, need not be 295 | included in conveying the object code work. 296 | 297 | A "User Product" is either (1) a "consumer product", which means any 298 | tangible personal property which is normally used for personal, family, 299 | or household purposes, or (2) anything designed or sold for incorporation 300 | into a dwelling. In determining whether a product is a consumer product, 301 | doubtful cases shall be resolved in favor of coverage. For a particular 302 | product received by a particular user, "normally used" refers to a 303 | typical or common use of that class of product, regardless of the status 304 | of the particular user or of the way in which the particular user 305 | actually uses, or expects or is expected to use, the product. A product 306 | is a consumer product regardless of whether the product has substantial 307 | commercial, industrial or non-consumer uses, unless such uses represent 308 | the only significant mode of use of the product. 309 | 310 | "Installation Information" for a User Product means any methods, 311 | procedures, authorization keys, or other information required to install 312 | and execute modified versions of a covered work in that User Product from 313 | a modified version of its Corresponding Source. The information must 314 | suffice to ensure that the continued functioning of the modified object 315 | code is in no case prevented or interfered with solely because 316 | modification has been made. 317 | 318 | If you convey an object code work under this section in, or with, or 319 | specifically for use in, a User Product, and the conveying occurs as 320 | part of a transaction in which the right of possession and use of the 321 | User Product is transferred to the recipient in perpetuity or for a 322 | fixed term (regardless of how the transaction is characterized), the 323 | Corresponding Source conveyed under this section must be accompanied 324 | by the Installation Information. But this requirement does not apply 325 | if neither you nor any third party retains the ability to install 326 | modified object code on the User Product (for example, the work has 327 | been installed in ROM). 328 | 329 | The requirement to provide Installation Information does not include a 330 | requirement to continue to provide support service, warranty, or updates 331 | for a work that has been modified or installed by the recipient, or for 332 | the User Product in which it has been modified or installed. Access to a 333 | network may be denied when the modification itself materially and 334 | adversely affects the operation of the network or violates the rules and 335 | protocols for communication across the network. 336 | 337 | Corresponding Source conveyed, and Installation Information provided, 338 | in accord with this section must be in a format that is publicly 339 | documented (and with an implementation available to the public in 340 | source code form), and must require no special password or key for 341 | unpacking, reading or copying. 342 | 343 | 7. Additional Terms. 344 | 345 | "Additional permissions" are terms that supplement the terms of this 346 | License by making exceptions from one or more of its conditions. 347 | Additional permissions that are applicable to the entire Program shall 348 | be treated as though they were included in this License, to the extent 349 | that they are valid under applicable law. If additional permissions 350 | apply only to part of the Program, that part may be used separately 351 | under those permissions, but the entire Program remains governed by 352 | this License without regard to the additional permissions. 353 | 354 | When you convey a copy of a covered work, you may at your option 355 | remove any additional permissions from that copy, or from any part of 356 | it. (Additional permissions may be written to require their own 357 | removal in certain cases when you modify the work.) You may place 358 | additional permissions on material, added by you to a covered work, 359 | for which you have or can give appropriate copyright permission. 360 | 361 | Notwithstanding any other provision of this License, for material you 362 | add to a covered work, you may (if authorized by the copyright holders of 363 | that material) supplement the terms of this License with terms: 364 | 365 | a) Disclaiming warranty or limiting liability differently from the 366 | terms of sections 15 and 16 of this License; or 367 | 368 | b) Requiring preservation of specified reasonable legal notices or 369 | author attributions in that material or in the Appropriate Legal 370 | Notices displayed by works containing it; or 371 | 372 | c) Prohibiting misrepresentation of the origin of that material, or 373 | requiring that modified versions of such material be marked in 374 | reasonable ways as different from the original version; or 375 | 376 | d) Limiting the use for publicity purposes of names of licensors or 377 | authors of the material; or 378 | 379 | e) Declining to grant rights under trademark law for use of some 380 | trade names, trademarks, or service marks; or 381 | 382 | f) Requiring indemnification of licensors and authors of that 383 | material by anyone who conveys the material (or modified versions of 384 | it) with contractual assumptions of liability to the recipient, for 385 | any liability that these contractual assumptions directly impose on 386 | those licensors and authors. 387 | 388 | All other non-permissive additional terms are considered "further 389 | restrictions" within the meaning of section 10. If the Program as you 390 | received it, or any part of it, contains a notice stating that it is 391 | governed by this License along with a term that is a further 392 | restriction, you may remove that term. If a license document contains 393 | a further restriction but permits relicensing or conveying under this 394 | License, you may add to a covered work material governed by the terms 395 | of that license document, provided that the further restriction does 396 | not survive such relicensing or conveying. 397 | 398 | If you add terms to a covered work in accord with this section, you 399 | must place, in the relevant source files, a statement of the 400 | additional terms that apply to those files, or a notice indicating 401 | where to find the applicable terms. 402 | 403 | Additional terms, permissive or non-permissive, may be stated in the 404 | form of a separately written license, or stated as exceptions; 405 | the above requirements apply either way. 406 | 407 | 8. Termination. 408 | 409 | You may not propagate or modify a covered work except as expressly 410 | provided under this License. Any attempt otherwise to propagate or 411 | modify it is void, and will automatically terminate your rights under 412 | this License (including any patent licenses granted under the third 413 | paragraph of section 11). 414 | 415 | However, if you cease all violation of this License, then your 416 | license from a particular copyright holder is reinstated (a) 417 | provisionally, unless and until the copyright holder explicitly and 418 | finally terminates your license, and (b) permanently, if the copyright 419 | holder fails to notify you of the violation by some reasonable means 420 | prior to 60 days after the cessation. 421 | 422 | Moreover, your license from a particular copyright holder is 423 | reinstated permanently if the copyright holder notifies you of the 424 | violation by some reasonable means, this is the first time you have 425 | received notice of violation of this License (for any work) from that 426 | copyright holder, and you cure the violation prior to 30 days after 427 | your receipt of the notice. 428 | 429 | Termination of your rights under this section does not terminate the 430 | licenses of parties who have received copies or rights from you under 431 | this License. If your rights have been terminated and not permanently 432 | reinstated, you do not qualify to receive new licenses for the same 433 | material under section 10. 434 | 435 | 9. Acceptance Not Required for Having Copies. 436 | 437 | You are not required to accept this License in order to receive or 438 | run a copy of the Program. Ancillary propagation of a covered work 439 | occurring solely as a consequence of using peer-to-peer transmission 440 | to receive a copy likewise does not require acceptance. However, 441 | nothing other than this License grants you permission to propagate or 442 | modify any covered work. These actions infringe copyright if you do 443 | not accept this License. Therefore, by modifying or propagating a 444 | covered work, you indicate your acceptance of this License to do so. 445 | 446 | 10. Automatic Licensing of Downstream Recipients. 447 | 448 | Each time you convey a covered work, the recipient automatically 449 | receives a license from the original licensors, to run, modify and 450 | propagate that work, subject to this License. You are not responsible 451 | for enforcing compliance by third parties with this License. 452 | 453 | An "entity transaction" is a transaction transferring control of an 454 | organization, or substantially all assets of one, or subdividing an 455 | organization, or merging organizations. If propagation of a covered 456 | work results from an entity transaction, each party to that 457 | transaction who receives a copy of the work also receives whatever 458 | licenses to the work the party's predecessor in interest had or could 459 | give under the previous paragraph, plus a right to possession of the 460 | Corresponding Source of the work from the predecessor in interest, if 461 | the predecessor has it or can get it with reasonable efforts. 462 | 463 | You may not impose any further restrictions on the exercise of the 464 | rights granted or affirmed under this License. For example, you may 465 | not impose a license fee, royalty, or other charge for exercise of 466 | rights granted under this License, and you may not initiate litigation 467 | (including a cross-claim or counterclaim in a lawsuit) alleging that 468 | any patent claim is infringed by making, using, selling, offering for 469 | sale, or importing the Program or any portion of it. 470 | 471 | 11. Patents. 472 | 473 | A "contributor" is a copyright holder who authorizes use under this 474 | License of the Program or a work on which the Program is based. The 475 | work thus licensed is called the contributor's "contributor version". 476 | 477 | A contributor's "essential patent claims" are all patent claims 478 | owned or controlled by the contributor, whether already acquired or 479 | hereafter acquired, that would be infringed by some manner, permitted 480 | by this License, of making, using, or selling its contributor version, 481 | but do not include claims that would be infringed only as a 482 | consequence of further modification of the contributor version. For 483 | purposes of this definition, "control" includes the right to grant 484 | patent sublicenses in a manner consistent with the requirements of 485 | this License. 486 | 487 | Each contributor grants you a non-exclusive, worldwide, royalty-free 488 | patent license under the contributor's essential patent claims, to 489 | make, use, sell, offer for sale, import and otherwise run, modify and 490 | propagate the contents of its contributor version. 491 | 492 | In the following three paragraphs, a "patent license" is any express 493 | agreement or commitment, however denominated, not to enforce a patent 494 | (such as an express permission to practice a patent or covenant not to 495 | sue for patent infringement). To "grant" such a patent license to a 496 | party means to make such an agreement or commitment not to enforce a 497 | patent against the party. 498 | 499 | If you convey a covered work, knowingly relying on a patent license, 500 | and the Corresponding Source of the work is not available for anyone 501 | to copy, free of charge and under the terms of this License, through a 502 | publicly available network server or other readily accessible means, 503 | then you must either (1) cause the Corresponding Source to be so 504 | available, or (2) arrange to deprive yourself of the benefit of the 505 | patent license for this particular work, or (3) arrange, in a manner 506 | consistent with the requirements of this License, to extend the patent 507 | license to downstream recipients. "Knowingly relying" means you have 508 | actual knowledge that, but for the patent license, your conveying the 509 | covered work in a country, or your recipient's use of the covered work 510 | in a country, would infringe one or more identifiable patents in that 511 | country that you have reason to believe are valid. 512 | 513 | If, pursuant to or in connection with a single transaction or 514 | arrangement, you convey, or propagate by procuring conveyance of, a 515 | covered work, and grant a patent license to some of the parties 516 | receiving the covered work authorizing them to use, propagate, modify 517 | or convey a specific copy of the covered work, then the patent license 518 | you grant is automatically extended to all recipients of the covered 519 | work and works based on it. 520 | 521 | A patent license is "discriminatory" if it does not include within 522 | the scope of its coverage, prohibits the exercise of, or is 523 | conditioned on the non-exercise of one or more of the rights that are 524 | specifically granted under this License. You may not convey a covered 525 | work if you are a party to an arrangement with a third party that is 526 | in the business of distributing software, under which you make payment 527 | to the third party based on the extent of your activity of conveying 528 | the work, and under which the third party grants, to any of the 529 | parties who would receive the covered work from you, a discriminatory 530 | patent license (a) in connection with copies of the covered work 531 | conveyed by you (or copies made from those copies), or (b) primarily 532 | for and in connection with specific products or compilations that 533 | contain the covered work, unless you entered into that arrangement, 534 | or that patent license was granted, prior to 28 March 2007. 535 | 536 | Nothing in this License shall be construed as excluding or limiting 537 | any implied license or other defenses to infringement that may 538 | otherwise be available to you under applicable patent law. 539 | 540 | 12. No Surrender of Others' Freedom. 541 | 542 | If conditions are imposed on you (whether by court order, agreement or 543 | otherwise) that contradict the conditions of this License, they do not 544 | excuse you from the conditions of this License. If you cannot convey a 545 | covered work so as to satisfy simultaneously your obligations under this 546 | License and any other pertinent obligations, then as a consequence you may 547 | not convey it at all. For example, if you agree to terms that obligate you 548 | to collect a royalty for further conveying from those to whom you convey 549 | the Program, the only way you could satisfy both those terms and this 550 | License would be to refrain entirely from conveying the Program. 551 | 552 | 13. Use with the GNU Affero General Public License. 553 | 554 | Notwithstanding any other provision of this License, you have 555 | permission to link or combine any covered work with a work licensed 556 | under version 3 of the GNU Affero General Public License into a single 557 | combined work, and to convey the resulting work. The terms of this 558 | License will continue to apply to the part which is the covered work, 559 | but the special requirements of the GNU Affero General Public License, 560 | section 13, concerning interaction through a network will apply to the 561 | combination as such. 562 | 563 | 14. Revised Versions of this License. 564 | 565 | The Free Software Foundation may publish revised and/or new versions of 566 | the GNU General Public License from time to time. Such new versions will 567 | be similar in spirit to the present version, but may differ in detail to 568 | address new problems or concerns. 569 | 570 | Each version is given a distinguishing version number. If the 571 | Program specifies that a certain numbered version of the GNU General 572 | Public License "or any later version" applies to it, you have the 573 | option of following the terms and conditions either of that numbered 574 | version or of any later version published by the Free Software 575 | Foundation. If the Program does not specify a version number of the 576 | GNU General Public License, you may choose any version ever published 577 | by the Free Software Foundation. 578 | 579 | If the Program specifies that a proxy can decide which future 580 | versions of the GNU General Public License can be used, that proxy's 581 | public statement of acceptance of a version permanently authorizes you 582 | to choose that version for the Program. 583 | 584 | Later license versions may give you additional or different 585 | permissions. However, no additional obligations are imposed on any 586 | author or copyright holder as a result of your choosing to follow a 587 | later version. 588 | 589 | 15. Disclaimer of Warranty. 590 | 591 | THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY 592 | APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT 593 | HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY 594 | OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, 595 | THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 596 | PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM 597 | IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF 598 | ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 599 | 600 | 16. Limitation of Liability. 601 | 602 | IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 603 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS 604 | THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY 605 | GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE 606 | USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF 607 | DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD 608 | PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), 609 | EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF 610 | SUCH DAMAGES. 611 | 612 | 17. Interpretation of Sections 15 and 16. 613 | 614 | If the disclaimer of warranty and limitation of liability provided 615 | above cannot be given local legal effect according to their terms, 616 | reviewing courts shall apply local law that most closely approximates 617 | an absolute waiver of all civil liability in connection with the 618 | Program, unless a warranty or assumption of liability accompanies a 619 | copy of the Program in return for a fee. 620 | 621 | END OF TERMS AND CONDITIONS 622 | 623 | How to Apply These Terms to Your New Programs 624 | 625 | If you develop a new program, and you want it to be of the greatest 626 | possible use to the public, the best way to achieve this is to make it 627 | free software which everyone can redistribute and change under these terms. 628 | 629 | To do so, attach the following notices to the program. It is safest 630 | to attach them to the start of each source file to most effectively 631 | state the exclusion of warranty; and each file should have at least 632 | the "copyright" line and a pointer to where the full notice is found. 633 | 634 | gopcaml-mode 635 | Copyright (C) 2020 Kiran Gopinathan 636 | 637 | This program is free software: you can redistribute it and/or modify 638 | it under the terms of the GNU General Public License as published by 639 | the Free Software Foundation, either version 3 of the License, or 640 | (at your option) any later version. 641 | 642 | This program is distributed in the hope that it will be useful, 643 | but WITHOUT ANY WARRANTY; without even the implied warranty of 644 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 645 | GNU General Public License for more details. 646 | 647 | You should have received a copy of the GNU General Public License 648 | along with this program. If not, see . 649 | 650 | Also add information on how to contact you by electronic and paper mail. 651 | 652 | If the program does terminal interaction, make it output a short 653 | notice like this when it starts in an interactive mode: 654 | 655 | gopcaml-mode Copyright (C) 2020 Kiran Gopinathan 656 | This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 657 | This is free software, and you are welcome to redistribute it 658 | under certain conditions; type `show c' for details. 659 | 660 | The hypothetical commands `show w' and `show c' should show the appropriate 661 | parts of the General Public License. Of course, your program's commands 662 | might be different; for a GUI interface, you would use an "about box". 663 | 664 | You should also get your employer (if you work as a programmer) or school, 665 | if any, to sign a "copyright disclaimer" for the program, if necessary. 666 | For more information on this, and how to apply and follow the GNU GPL, see 667 | . 668 | 669 | The GNU General Public License does not permit incorporating your program 670 | into proprietary programs. If your program is a subroutine library, you 671 | may consider it more useful to permit linking proprietary applications with 672 | the library. If this is what you want to do, use the GNU Lesser General 673 | Public License instead of this License. But first, please read 674 | . 675 | -------------------------------------------------------------------------------- /ast_transformer.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Generic_types 3 | 4 | (* returns total bounds of the current item *) 5 | let bounds_iterator () = 6 | let min_position = ref None in 7 | let max_position = ref None in 8 | let retrieve_bounds () = Option.value_exn !min_position, Option.value_exn !max_position in 9 | let update_bounds pstr_loc = 10 | let open Lexing in 11 | let open Location in 12 | let () = 13 | let start_cnum = min pstr_loc.loc_end.pos_cnum pstr_loc.loc_start.pos_cnum in 14 | let min_cnum = match !min_position with 15 | None -> start_cnum 16 | | Some v -> v in 17 | if start_cnum = -1 then () 18 | else min_position := Some (min min_cnum start_cnum) 19 | in 20 | let () = 21 | let end_cnum = max pstr_loc.loc_end.pos_cnum pstr_loc.loc_start.pos_cnum in 22 | let max_cnum = match !max_position with 23 | None -> end_cnum 24 | | Some v -> v in 25 | if end_cnum = -1 then () 26 | else max_position := Some (max max_cnum end_cnum) 27 | in 28 | () 29 | in 30 | Ast_iterator.{ 31 | default_iterator 32 | with 33 | location = fun _ -> update_bounds 34 | }, retrieve_bounds 35 | 36 | let complete_bounds_iterator () = 37 | let min_col_position = ref (-1) in 38 | let max_col_position = ref (-1) in 39 | let min_line_position = ref (-1) in 40 | let max_line_position = ref (-1) in 41 | let cmp f a b = match (a,b) with 42 | | -1, -1 -> -1 43 | | -1, b -> b 44 | | a, -1 -> a 45 | | a, b -> f a b in 46 | let min = cmp min in 47 | let max = cmp max in 48 | let retrieve_bounds () = 49 | (!min_line_position, !min_col_position), 50 | (!max_line_position, !max_col_position) 51 | in 52 | let update_bounds pstr_loc = 53 | let open Lexing in 54 | let open Location in 55 | let () = 56 | min_col_position := min !min_col_position pstr_loc.loc_start.pos_cnum; 57 | min_line_position := min !min_line_position pstr_loc.loc_start.pos_lnum; 58 | max_col_position := max !max_col_position pstr_loc.loc_end.pos_cnum; 59 | max_line_position := max !max_line_position pstr_loc.loc_end.pos_lnum; 60 | in 61 | () 62 | in 63 | Ast_iterator.{ 64 | default_iterator 65 | with 66 | location = fun _ -> update_bounds 67 | }, retrieve_bounds 68 | 69 | (* returns the nearest enclosing bounds to a point *) 70 | let enclosing_bounds_iterator point () = 71 | let bounds = ref None in 72 | let retrieve_bounds () = !bounds in 73 | let within_bounds st ed point = st <= point && point <= ed in 74 | let encloses (st,ed) (st',ed') = 75 | within_bounds st ed st' && within_bounds st ed ed' in 76 | let smaller (st,ed) (st',ed') = 77 | ed - st <= st' - ed' in 78 | (* given two regions enclosing point, returns the smaller one*) 79 | let choose (st,ed) (st',ed') = 80 | if encloses (st,ed) (st',ed') || smaller (st',ed') (st,ed) 81 | then (st',ed') 82 | else (st,ed) in 83 | let update_bounds ({ 84 | loc_start={ pos_cnum=st;_ }; 85 | loc_end={pos_cnum=ed;_}; _ 86 | }: Location.t) = 87 | if within_bounds st ed point then 88 | match !bounds with 89 | | None -> bounds := Some (st,ed) 90 | | Some (st',ed') -> bounds := Some (choose (st,ed) (st',ed')) 91 | else () in 92 | Ast_iterator.{ 93 | default_iterator 94 | with 95 | location = fun _ -> update_bounds 96 | },retrieve_bounds 97 | 98 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | # Gopcaml Changelog 2 | - Version 0.0.6 - Like the Phoenix Release 3 | - *Updated to work with OCaml 4.13.0 and OCaml 4.14.0* 4 | - Version 0.0.3 - Polishing release 5 | - *Added support for customisable verbosity* 6 | - Customise the Emacs variable `gopcaml-messaging-level` to change 7 | the level of messages that are output by GopCaml. Set it to 8 | `'none` to disable messages entirely. 9 | - *Fixed bug when starting zipper mode at the start of a file.* 10 | - Zipper mode selects the immediately prior byte position to avoid 11 | inconsistencies when the cursor is just on the edge of an 12 | expression, but when the cursor is at position 1, this causes an 13 | error as 0 is not a valid point. 14 | - *Special casing of shebangs* 15 | - Added support for handling shebangs at the start of a buffer. 16 | - Implemented as part of a larger library for preprocessing buffer 17 | text before running the parser on it - could be extended to 18 | support additional preprocessing in the future. 19 | - Another possible direction for extension is to use an Emacs 20 | callback to modify the text, although this may not be ideal, as 21 | the parsing has to be as fast as possible. 22 | 23 | - Version 0.0.2 - Unicode-lovers & Refactoring release 24 | - *Updated to work with OCaml 4.12.0* 25 | - Updated to depend on ocaml-migrate-parsetree, back-porting support back to OCaml.4.08.0+ 26 | - *Improved support for jumping to nearest pattern* 27 | - Pressing C-c C-p will now jump to the nearest enclosing wildcard or pattern if no wildcard exists 28 | - C-c C-o operates as normal for jumping to the nearest let definition 29 | - *Added support for moving within patterns* 30 | - *Added support for moving within types* 31 | - *improved quality of main Ast_zipper code* 32 | - more comments 33 | - refactoring TextRegion module to a separate file so it may be 34 | reused for other analyses 35 | - *Added support for excluding files* 36 | - Now does not complain when opening ocamllex or menhir files 37 | - see `gopcaml-ignored-extensions` variable for more information 38 | - *Fixed ordering of parameters when using optional arguments* 39 | - previously optional arguments would appear before their bindings 40 | - *Added better support for multi-byte strings* 41 | - previously, use of multi-byte strings would cause overlays to 42 | desynchronise with the code 43 | - the OCaml parser represents offsets and ranges in terms of byte 44 | offsets, while the conversion functions being used in the 45 | program (Position.of_int_exn) assumed they were code points 46 | - the existing code would function correctly on buffers using only 47 | single-byte characters, but would fail on buffers with 48 | multi-byte buffers 49 | - now our unicode using foriegn-language friends can too enjoy the 50 | power of Gopcaml mode! 51 | - *Fixed bug with transpose expression* 52 | 53 | - Version 0.0.1 - Initial release 54 | -------------------------------------------------------------------------------- /dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name gopcaml) 3 | (libraries core ecaml generic_parser ocaml-migrate-parsetree) 4 | (preprocess (pps ppx_let ppx_here ppx_deriving.std ppx_sexp_conv)) 5 | (modes (native shared_object)) 6 | (flags "-w" "-33")) 7 | 8 | 9 | (install 10 | (section share_root) 11 | (files (gopcaml-mode.el as emacs/site-lisp/gopcaml-mode.el) 12 | (gopcaml-smartparens.el as emacs/site-lisp/gopcaml-smartparens.el) 13 | (gopcaml-multiple-cursors.el as emacs/site-lisp/gopcaml-multiple-cursors.el) 14 | )) 15 | (install 16 | (section lib) 17 | (files gopcaml.so)) 18 | 19 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.10) 2 | (package 3 | (name gopcaml-mode) 4 | (synopsis "Ultimate Ocaml editing plugin, providing advanced structural editing, movement and analysis in Emacs") 5 | (description "Gopcaml-mode is a plugin for emacs for editing OCaml code. It aims to extend existing Emacs editing experience to closer match the features in modern IDEs.") 6 | (depends 7 | (merlin (>= 2.5.0)) 8 | (ocp-indent (>= 1.0.0)) 9 | (ocaml (>= 4.08.0)) 10 | (core (>= 0.13.0)) 11 | (ppx_deriving (>= 4.4)) 12 | (ocaml-migrate-parsetree (>= 2.1.0)) 13 | (ecaml (>= 0.13.0)))) 14 | (version 0.0.2) 15 | (name gopcaml-mode) 16 | (generate_opam_files true) 17 | (license GPL-3.0-only) 18 | (source (uri git+https://gitlab.com/gopiandcode/gopcaml-mode.git)) 19 | (bug_reports https://gitlab.com/gopiandcode/gopcaml-mode/issues) 20 | (homepage https://gitlab.com/gopiandcode/gopcaml-mode) 21 | (authors "Kiran Gopinathan") 22 | (maintainers "kirang@comp.nus.edu.sg") 23 | 24 | -------------------------------------------------------------------------------- /extras/readme.md: -------------------------------------------------------------------------------- 1 | # Extra features 2 | 3 | This document lists a number of optional features that can be applied 4 | to further improve your editing experience. 5 | 6 | ## Emacs Compilation integration 7 | You can configure emacs to automatically use dune build as the compile command using the following snippet: 8 | ``` 9 | (add-hook 'tuareg-mode-hook 10 | #'(lambda () 11 | (set (make-local-variable 'compile-command) 12 | (concat "dune build")) 13 | (set (make-local-variable 'compilation-read-command) 14 | nil) 15 | )) 16 | ``` 17 | This just reduces the friction between editing and compilation (just press `C-c C-c` and the project is rebuilt). 18 | 19 | ## YASnippets integration 20 | If you use YASnippets, Gopcaml mode provides a few functions that can 21 | be used to improve the snippet expansion process for ocaml. 22 | 23 | To use them, simply move over the snippets directory to 24 | `~/.emacs.d/snippets/tuareg-mode` 25 | 26 | For my own emacs config, I have also configured yas-snippets to 27 | auto-expand snippets after pressing space. This significantly improves 28 | the editing experience and makes it easier to maintain a valid AST, 29 | as the snippet expansions automatically handle the boilerplate: 30 | ```elisp 31 | (defun yas-no-expand-in-comment/string () 32 | (setq yas-buffer-local-condition 33 | '(if (nth 8 (syntax-ppss)) ;; non-nil if in a string or comment 34 | '(require-snippet-condition . force-in-comment) 35 | t))) 36 | ;; don't expand in comments 37 | (add-hook 'prog-mode-hook 'yas-no-expand-in-comment/string) 38 | ;; expand on pressing space 39 | (define-key yas-minor-mode-map (kbd "SPC") yas-maybe-expand) 40 | ;; only expand if we typed the last letter 41 | (setq yas-expand-only-for-last-commands '(self-insert-command)) 42 | ``` 43 | ## Smartparens integration 44 | By default gopcaml-mode integrates with smartparens automatically - 45 | this is achieved by disabling the movement commands when the cursor is 46 | on a parens understood by smartparens mode. With this integration, 47 | movement around parens is significantly more natural. 48 | 49 | I personally also have some additional functions for smart-parens 50 | that ensure parenthesis are deleted in pairs (it works as a nice 51 | parallel to the wrapping functionality that smartparens usually provides): 52 | ```elisp 53 | (defun sp-paired-delete-char-forward (&optional arg) 54 | "Delete char forward, deleting parens pair if deleting parens." 55 | (interactive "p") 56 | (setq arg (or arg 1)) 57 | (if (<= arg 0) (sp-paired-delete-char-backward (- arg)) 58 | (let ((any-changes nil)) 59 | (do ((i 0 (+ i 1))) ((>= i arg)) 60 | (let ((inhibit-message t) 61 | ) 62 | (unless (or (when (save-match-data 63 | (sp--looking-at 64 | (sp--get-opening-regexp 65 | (sp--get-pair-list-context 'navigate)))) 66 | (let (ok curr) 67 | (forward-char 1) 68 | (setq curr (point)) 69 | (setq ok (sp-get-enclosing-sexp 1)) 70 | (progn 71 | (cond 72 | ((and ok 73 | (< (sp-get ok :beg) curr ) 74 | (<= curr (sp-get ok :beg-in))) 75 | (sp-splice-sexp) 76 | (backward-char 1) 77 | (setq any-changes t) 78 | t 79 | ) 80 | (t 81 | (backward-char 1) 82 | nil) 83 | )) 84 | )) 85 | (when 86 | (save-match-data 87 | (sp--looking-at 88 | (sp--get-closing-regexp 89 | (sp--get-pair-list-context 'navigate)))) 90 | (let (ok curr) 91 | (setq curr (point)) 92 | (setq ok (sp-get-enclosing-sexp 1)) 93 | (progn 94 | (cond 95 | ((and ok (or (and 96 | (<= (sp-get ok :beg) curr ) 97 | (< curr (sp-get ok :beg-in))) 98 | (and 99 | (<= (sp-get ok :end-in) curr ) 100 | (< curr (sp-get ok :end))))) 101 | (sp-splice-sexp) 102 | t 103 | ) 104 | (t 105 | nil) 106 | )) 107 | )) 108 | ) 109 | (delete-forward-char 1) 110 | )) 111 | ) 112 | (if any-changes (forward-char 1))) 113 | ) 114 | ) 115 | 116 | (defun sp-paired-delete-char-backward (&optional arg) 117 | "Delete char backward, deleting parens pair if deleting parens." 118 | (interactive "p") 119 | (setq arg (or arg 1)) 120 | (if (< arg 0) (sp-paired-delete-char-forward (- arg))) 121 | (do ((i 0 (+ i 1))) ((>= i arg)) 122 | (let ((inhibit-message t)) 123 | (unless (or (when 124 | (sp--looking-back 125 | (sp--get-closing-regexp 126 | (sp--get-pair-list-context 'navigate))) 127 | (let (ok curr) 128 | (backward-char 1) 129 | (setq curr (point)) 130 | (setq ok (sp-get-enclosing-sexp 1)) 131 | (progn 132 | (cond 133 | ((and ok (or (and 134 | (<= (sp-get ok :beg) curr ) 135 | (< curr (sp-get ok :beg-in))) 136 | (and 137 | (<= (sp-get ok :end-in) curr ) 138 | (< curr (sp-get ok :end))))) 139 | (sp-splice-sexp) 140 | t 141 | ) 142 | (t 143 | (forward-char 1) 144 | nil) 145 | )) 146 | )) 147 | (when 148 | (save-match-data 149 | (sp--looking-back 150 | (sp--get-opening-regexp 151 | (sp--get-pair-list-context 'navigate)))) 152 | (let (ok (curr (point))) 153 | (setq ok (sp-get-enclosing-sexp 1)) 154 | (progn 155 | (cond 156 | ((and ok 157 | (< (sp-get ok :beg) curr ) 158 | (<= curr (sp-get ok :beg-in))) 159 | (sp-splice-sexp) 160 | t 161 | ) 162 | (t 163 | nil) 164 | )) 165 | )) 166 | ) 167 | (backward-delete-char-untabify 1) 168 | )) 169 | )) 170 | 171 | (defun sp-paired-delete-char (&optional arg) 172 | "Deletes char, and parens if present." 173 | (interactive "p^") 174 | (setq arg (or arg 1)) 175 | (if (< arg 0) 176 | (sp-paired-backward-delete-char-untabify (- arg))) 177 | (sp-paired-delete-char-forward arg)) 178 | 179 | (define-key prog-mode-map [remap backward-delete-char-untabify] 180 | #'sp-paired-delete-char-backward) 181 | ;; (define-key prog-mode-map [remap kill-line] 182 | ;; #'kill-line) 183 | (define-key prog-mode-map 184 | [remap delete-char] #'sp-paired-delete-char) 185 | (define-key prog-mode-map 186 | [remap delete-forward-char] #'sp-paired-delete-char-forward) 187 | ``` 188 | -------------------------------------------------------------------------------- /extras/snippets/assert: -------------------------------------------------------------------------------- 1 | # -*- mode: snippet -*- 2 | # name: assert 3 | # key: assert 4 | # -- 5 | assert ${1:(??)}`(if (and (boundp 'gopcaml-state) 6 | gopcaml-state (fboundp 'gopcaml-is-inside-let-def) 7 | (car (gopcaml-is-inside-let-def (point)))) ";")`$0 -------------------------------------------------------------------------------- /extras/snippets/begin: -------------------------------------------------------------------------------- 1 | # -*- mode: tuareg -*- 2 | # name: begin 3 | # key: begin 4 | # -- 5 | begin ${1:(??)} end 6 | -------------------------------------------------------------------------------- /extras/snippets/for: -------------------------------------------------------------------------------- 1 | # -*- mode: snippet -*- 2 | # name: for 3 | # key: for 4 | # -- 5 | for ${1:cond} do ${0:(??)} done`(if (and (boundp 'gopcaml-state) gopcaml-state (fboundp 'gopcaml-is-inside-let-def) 6 | (car (gopcaml-is-inside-let-def (point)))) ";")` -------------------------------------------------------------------------------- /extras/snippets/fun: -------------------------------------------------------------------------------- 1 | # -*- mode: snippet -*- 2 | # name: fun 3 | # key: fun 4 | # -- 5 | fun ${1:args} -> $0 -------------------------------------------------------------------------------- /extras/snippets/guard: -------------------------------------------------------------------------------- 1 | # -*- mode: snippet -*- 2 | # name: guard 3 | # key: |m 4 | # -- 5 | | ${1:_} -> $0 -------------------------------------------------------------------------------- /extras/snippets/ifelse: -------------------------------------------------------------------------------- 1 | # -*- mode: snippet -*- 2 | # name: ifelse 3 | # key: if 4 | # -- 5 | if ${1:(??)} then ${2:(??)} else ${3:(??)} -------------------------------------------------------------------------------- /extras/snippets/ifthen: -------------------------------------------------------------------------------- 1 | # -*- mode: snippet -*- 2 | # name: ift 3 | # key: ift 4 | # -- 5 | if ${1:(??)} then ${2:(??)}`(if (and (boundp 'gopcaml-state) gopcaml-state (fboundp 'gopcaml-is-inside-let-def) 6 | (car (gopcaml-is-inside-let-def (point)))) ";")` -------------------------------------------------------------------------------- /extras/snippets/let-in: -------------------------------------------------------------------------------- 1 | # -*- mode: snippet -*- 2 | # name: let in 3 | # key: let 4 | # -- 5 | let ${1:_} = ${2:(??)}`(if 6 | (and (boundp 'gopcaml-state) gopcaml-state 7 | (fboundp 'gopcaml-is-inside-let-def) 8 | (car (gopcaml-is-inside-let-def (point)))) 9 | "in")` 10 | -------------------------------------------------------------------------------- /extras/snippets/match: -------------------------------------------------------------------------------- 1 | # -*- mode: snippet -*- 2 | # name: match 3 | # key: match 4 | # -- 5 | match ${1:(??)} with 6 | | ${2:_} -> ${3:(??)} -------------------------------------------------------------------------------- /extras/snippets/printf: -------------------------------------------------------------------------------- 1 | # -*- mode: snippet -*- 2 | # name: printf 3 | # key: pr 4 | # -- 5 | Printf.printf "${1:%s}" ${2:(??)} -------------------------------------------------------------------------------- /extras/snippets/sexp: -------------------------------------------------------------------------------- 1 | # -*- mode: snippet -*- 2 | # name: sexp 3 | # key: sexp 4 | # -- 5 | [@@deriving sexp] -------------------------------------------------------------------------------- /extras/snippets/signature: -------------------------------------------------------------------------------- 1 | # -*- mode: snippet -*- 2 | # name: signature 3 | # key: sig 4 | # -- 5 | sig $0 end -------------------------------------------------------------------------------- /extras/snippets/sprintf: -------------------------------------------------------------------------------- 1 | # -*- mode: snippet -*- 2 | # name: sprintf 3 | # key: spr 4 | # -- 5 | Printf.sprintf ${1:"%s"} $0 -------------------------------------------------------------------------------- /extras/snippets/struct: -------------------------------------------------------------------------------- 1 | # -*- mode: snippet -*- 2 | # name: struct 3 | # key: struct 4 | # -- 5 | struct $0 end 6 | -------------------------------------------------------------------------------- /extras/snippets/try: -------------------------------------------------------------------------------- 1 | # -*- mode: snippet -*- 2 | # name: try 3 | # key: try 4 | # -- 5 | try ${1:(??)} with ${2:_} -> ${3:(??)} -------------------------------------------------------------------------------- /extras/snippets/while: -------------------------------------------------------------------------------- 1 | # -*- mode: snippet -*- 2 | # name: while 3 | # key: while 4 | # -- 5 | while ${1:(??)} do ${2:(??)} done`(if (and gopcaml-state (fboundp 'gopcaml-is-inside-let-def) 6 | (car (gopcaml-is-inside-let-def (point)))) ";")` -------------------------------------------------------------------------------- /gopcaml-mode.el: -------------------------------------------------------------------------------- 1 | ;;; gopcaml-mode.el --- Structural Ocaml Editing -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2020 Kiran Gopinathan 4 | 5 | ;; Author: Kiran Gopinathan 6 | ;; Keywords: languages, tools 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; 24 | 25 | ;;; Code: 26 | ;;;; Requirements and environment setup 27 | ;; load in core Gopcaml library 28 | 29 | (cond 30 | ((and (boundp 'gopcaml-dev-mode) gopcaml-dev-mode) 31 | ;; if in dev mode, 32 | (message "loading gopcaml-mode [dev]") 33 | (require 'gopcaml 34 | ;; load dynamic module from the build directory 35 | (expand-file-name "./_build/default/gopcaml.so" 36 | (string-trim 37 | (shell-command-to-string (format "dirname %s" 38 | (or (and (boundp 'file) file) 39 | (buffer-file-name (current-buffer)) 40 | ))))))) 41 | (t 42 | (message "loading gopcaml-mode [normal]") 43 | (let ((opam-lib (ignore-errors (car (process-lines "opam" "var" "lib"))))) 44 | (if (and opam-lib (file-directory-p opam-lib)) 45 | (require 'gopcaml (expand-file-name "./gopcaml-mode/gopcaml.so" opam-lib)) 46 | (error "Could not find opam - please make sure it is installed") 47 | )))) 48 | 49 | ;; load in emacs dependencies 50 | (require 'subr-x) 51 | ;; load in merlin/ocp deps 52 | (require 'ocp-indent) 53 | (require 'merlin) 54 | 55 | ;;;; Customization 56 | ;;;;; Faces 57 | (defgroup gopcaml-faces nil 58 | "Faces for gopcaml mode." 59 | :group 'gopcaml-mode 60 | :group 'faces) 61 | 62 | (defface gopcaml-highlight-face 63 | '((t :inherit caml-types-expr-face)) 64 | "Face for highlighting expr." 65 | :group 'gopcaml-faces) 66 | 67 | (defface gopcaml-zipper-face 68 | '((t (:background "dark slate gray"))) 69 | "Face for highlighting zipper." 70 | :group 'gopcaml-faces) 71 | 72 | ;;;;; Options 73 | 74 | (defcustom gopcaml-rebuild-delay 1 75 | "Number of idling seconds before rebuilding gopcaml-state." 76 | :type 'integer 77 | :group 'gopcaml) 78 | 79 | ;;;; Local variables 80 | 81 | (defvar-local gopcaml-temporary-highlight-overlays nil 82 | "Maintains an the overlay used for single-element highlights.") 83 | 84 | (defvar-local gopcaml-zipper-overlay nil 85 | "Overlay used to highlight the zipper region.") 86 | 87 | (defvar-local gopcaml-update-timer nil 88 | "Timer object used to periodically update gopcaml state.") 89 | 90 | (defvar-local gopcaml-expand-timer nil 91 | "Timer object used to periodically expand the element under point") 92 | 93 | (defvar-local gopcaml-zipper-mode-quit nil 94 | "Function that can be called to quit the zipper mode.") 95 | 96 | ;;;; Helper functions 97 | 98 | (defun gopcaml-remove-stored-overlays (&optional group) 99 | "Remove stored overlays - optionally only those of gopcaml-kind GROUP." 100 | (setq gopcaml-temporary-highlight-overlays 101 | (remove-if (lambda (it) (null it)) 102 | (mapcar (lambda (it) 103 | (if (or (not group) 104 | (equal (overlay-get it 'gopcaml-kind) 105 | group)) 106 | (delete-overlay it) 107 | nil)) 108 | gopcaml-temporary-highlight-overlays)))) 109 | 110 | (defun gopcaml-store-overlays (overlay &optional group) 111 | "Store an OVERLAY - optionally only those of gopcaml-kind GROUP." 112 | (overlay-put overlay 'gopcaml-kind group) 113 | (push overlay gopcaml-temporary-highlight-overlays)) 114 | 115 | (defun gopcaml-is-excluded-current-file () 116 | "Determines whether the current file has been designated as an 117 | ignored file." 118 | (let ((excluded-extensions 119 | (or (and (boundp 'gopcaml-ignored-extensions) gopcaml-ignored-extensions) 120 | '("mll" "mly"))) 121 | (file-extension (file-name-extension (buffer-file-name)))) 122 | (member file-extension excluded-extensions))) 123 | 124 | ;;;;; Highlighting functions 125 | (defun gopcaml-temporarily-highlight-region (bounds &optional group face) 126 | "Temporarily highlight region enclosed by BOUNDS using FACE. 127 | removes all existing overlays of type GROUP if present." 128 | (unless face 129 | (setq face 'gopcaml-highlight-face)) 130 | ;; when group is present, remove all existing overlays of the same group 131 | (gopcaml-remove-stored-overlays group) 132 | (lexical-let ((overlay (make-overlay (car bounds) (cdr bounds)))) 133 | (overlay-put overlay 'face face) 134 | (gopcaml-store-overlays overlay group) 135 | ;; wait for user input 136 | (unwind-protect 137 | (sit-for 60) (gopcaml-remove-stored-overlays group)))) 138 | 139 | (defun gopcaml-temporarily-highlight-multiple-region (mbounds &optional group face) 140 | "Temporarily highlight regions listed in MBOUNDS using FACE. 141 | removes all existing overlays of type GROUP if present." 142 | (unless face 143 | (setq face 'gopcaml-highlight-face)) 144 | ;; when group is present, remove all existing overlays of the same group 145 | (gopcaml-remove-stored-overlays group) 146 | (dolist (bounds mbounds) 147 | (lexical-let ((overlay (make-overlay (car bounds) (cdr bounds)))) 148 | (overlay-put overlay 'face face) 149 | (gopcaml-store-overlays overlay group))) 150 | ;; wait for user input 151 | (unwind-protect 152 | (sit-for 60) (gopcaml-remove-stored-overlays group)) 153 | ) 154 | 155 | (defun gopcaml-highlight-current-structure-item () 156 | "Highlight the structure-item enclosing the current point." 157 | (interactive) 158 | (let ((area (gopcaml-get-enclosing-bounds (point))) 159 | start end) 160 | (when area 161 | (setq start (caar area)) 162 | (setq end (cadar area)) 163 | (gopcaml-temporarily-highlight-region (cons start end))))) 164 | 165 | (defun gopcaml-highlight-dirty-region () 166 | "Highlight the dirty region." 167 | (interactive) 168 | (let ((area (car (gopcaml-get-dirty-region))) 169 | start end) 170 | (when area 171 | (setq start (car area)) 172 | (setq end (cdr area)) 173 | (gopcaml-temporarily-highlight-region (cons start end))))) 174 | 175 | ;;;;; Zipper Movement 176 | 177 | (defun move-gopcaml-zipper (zipper-fn &optional direction initial) 178 | "Move the zipper using ZIPPER-FN in direction DIRECTION." 179 | (let ((area (car (gopcaml-retrieve-zipper-bounds))) 180 | start end (point (point)) (buf-name (buffer-name))) 181 | (if area 182 | (progn 183 | (setq start (car area)) 184 | (setq end (cadr area)) 185 | (cond 186 | ((and 187 | (not initial) 188 | (equal point start) 189 | (equal direction 'forward) 190 | ) 191 | (goto-char end) 192 | t) 193 | ((and 194 | (not initial) 195 | (equal point end) 196 | (equal direction 'backward) 197 | ) 198 | (goto-char start) 199 | t) 200 | ((and 201 | initial 202 | (< point start) 203 | (equal direction 'forward) 204 | ) 205 | (goto-char start) 206 | t) 207 | ((and 208 | initial 209 | (> point end) 210 | (equal direction 'backward) 211 | ) 212 | (goto-char end) 213 | t) 214 | (t 215 | (setq area (car (funcall zipper-fn))) 216 | (if area 217 | (progn 218 | (setq start (car area)) 219 | (setq end (cadr area)) 220 | (move-overlay gopcaml-zipper-overlay start end) 221 | ;; (let ((wind-start (window-start)) (wind-end (window-end))) 222 | ;; (if (and wind-start wind-end (< wind-start start wind-end)) 223 | ;; (set-window-point (get-buffer-window buf-name) start) 224 | ;; (goto-char start)) 225 | ;; ) 226 | (if (equal direction 'forward) (if (< end (window-end)) 227 | (goto-char end) 228 | (goto-char start)) 229 | (if (> start (window-start)) 230 | (goto-char start) 231 | (goto-char end) 232 | )) 233 | t 234 | ) 235 | nil)))) 236 | nil))) 237 | 238 | (defun gopcaml-zipper-mode-and-move (operation &optional 239 | zipper-constructor selection-mode direction skip-zipper-mode) 240 | "Start gopcaml-zipper mode using ZIPPER-CONSTRUCTOR and perform OPERATION. 241 | SELECTION-MODE indicates whether this was called in the context 242 | of an existing selection, allowing for some slightly more 243 | ergonomic movement when dealing with selections. DIRECTION 244 | indicates the direction of the movement - allows skipping 245 | whitespace in direction before constructing zipper. 246 | SKIP-ZIPPER-MODE if set will prevent the activation zipper mode." 247 | (interactive) 248 | (if (not zipper-constructor) 249 | (setq zipper-constructor #'gopcaml-build-zipper)) 250 | (let ((starting-pos (point)) 251 | (selection-active (or (region-active-p) selection-mode))) 252 | (if (and selection-active (not (region-active-p)) (not skip-zipper-mode)) 253 | ;; if selection active and not region active 254 | ;; i.e we're holding shift, but haven't selecting anything 255 | (progn 256 | (push-mark (point)) 257 | (activate-mark))) 258 | 259 | ;; if not already in zipper mode 260 | (if (not gopcaml-zipper) 261 | ;; build zipper around point 262 | (progn 263 | (cond 264 | ((equal direction 'forward) 265 | (skip-chars-forward " \n\t")) 266 | ((equal direction 'backward) 267 | (skip-chars-backward " \n\t"))) 268 | (let ((area 269 | (car (funcall zipper-constructor 270 | (point) 271 | (line-number-at-pos) 272 | (list direction)))) 273 | start end overlay) 274 | ;; if successfull then perform operation 275 | (if area 276 | (progn 277 | (setq start (car area)) 278 | (setq end (cadr area)) 279 | (cond 280 | ;; if skip-zipper mode 281 | (skip-zipper-mode 282 | ;; just perform the operation and return the range 283 | (setq area (car (funcall operation t))) 284 | (gopcaml-delete-zipper) 285 | (goto-char starting-pos) 286 | area) 287 | (t 288 | (setq overlay (make-overlay start end)) 289 | (if (not selection-active) 290 | ;; (overlay-put overlay 'face 'gopcaml-selection-face) 291 | (overlay-put overlay 'face 'gopcaml-zipper-face) 292 | ) 293 | (overlay-put overlay 'gopcaml-kind 'zipper) 294 | (setq gopcaml-zipper-overlay overlay) 295 | (setq gopcaml-zipper-mode-pred t) 296 | (setq gopcaml-zipper-mode-quit 297 | (set-transient-map 298 | (if (not selection-active) 299 | gopcaml-zipper-mode-map 300 | gopcaml-selection-zipper-mode-map) 301 | t #'gopcaml-on-exit-zipper-mode)) 302 | ;; (funcall operation t) 303 | (cond 304 | ((equal direction 'forward) 305 | (goto-char end) 306 | ) 307 | ((equal direction 'backward) 308 | (goto-char start) 309 | ))))) 310 | (gopcaml-delete-zipper) 311 | (when skip-zipper-mode 312 | (goto-char starting-pos)) 313 | nil 314 | ))) 315 | ;; otherwise just perfom operation 316 | (cond 317 | (skip-zipper-mode 318 | ;; just perform the operation and return the range 319 | (let ((area (car (funcall operation t)))) 320 | (if gopcaml-zipper-mode-quit 321 | (funcall gopcaml-zipper-mode-quit) 322 | (gopcaml-delete-zipper)) 323 | area 324 | )) 325 | (t (funcall operation nil))) 326 | ))) 327 | 328 | (defun gopcaml-zipper-mark-mode () 329 | "Start gopcaml-zipper mark mode." 330 | (interactive) 331 | (let ((starting-pos (point)) 332 | (selection-active (and transient-mark-mode mark-active))) 333 | ;; if not already in zipper mode 334 | (if selection-active (setq starting-pos (min (mark) (region-end) (region-beginning) starting-pos))) 335 | (if (not gopcaml-zipper) 336 | ;; build zipper aronud point 337 | (progn 338 | (skip-chars-forward " \n\t") 339 | 340 | (let ((area 341 | (car (gopcaml-build-zipper 342 | (point) 343 | (line-number-at-pos) 344 | nil))) 345 | start end overlay) 346 | ;; if successfull then perform operation 347 | (if area 348 | (progn 349 | (setq start (car area)) 350 | (setq end (cadr area)) 351 | (setq overlay (make-overlay start end)) 352 | (overlay-put overlay 'gopcaml-kind 'zipper) 353 | (setq gopcaml-zipper-overlay overlay) 354 | (setq gopcaml-zipper-mode-quit 355 | (set-transient-map 356 | gopcaml-mark-zipper-mode-map 357 | t #'gopcaml-on-exit-zipper-mode)) 358 | ;; (funcall operation t) 359 | (if selection-active 360 | (progn 361 | (save-excursion 362 | (goto-char (max end (region-end))) 363 | (push-mark (point)) 364 | (activate-mark)) 365 | (goto-char (min start starting-pos))) 366 | (progn 367 | (save-excursion 368 | (goto-char end) 369 | (set-mark (point)) 370 | (activate-mark)) 371 | (goto-char (min start starting-pos)))) 372 | ) 373 | (gopcaml-delete-zipper) 374 | ))) 375 | ;; otherwise just perfom operation 376 | (let ((area (car (gopcaml-move-zipper-up)))) 377 | (if area 378 | (progn 379 | (setq start (car area)) 380 | (setq end (cadr area)) 381 | (move-overlay gopcaml-zipper-overlay start end) 382 | ;; (funcall operation t) 383 | (save-excursion 384 | (goto-char (max end (region-end))) 385 | (set-mark (point)) 386 | (activate-mark)) 387 | (goto-char (min start (region-beginning))) 388 | ) 389 | ) 390 | )))) 391 | 392 | ;;;;; User facing operations 393 | (defun gopcaml-get-current-item-bounds () 394 | "Return the bounds of the current item." 395 | (gopcaml-zipper-mode-and-move 396 | (lambda (_) (gopcaml-move-zipper-up)) nil nil 'forward t) 397 | ) 398 | 399 | (defun gopcaml-indent-current-sexp () 400 | "Indent the current sexp." 401 | (interactive) 402 | (let ((area (gopcaml-get-current-item-bounds))) 403 | (when area 404 | (ocp-indent-region (car area) (cadr area)))) 405 | ) 406 | 407 | (defun gopcaml-beginning-defun () 408 | "Move backwards to the beginning of the defun." 409 | (interactive) 410 | (let ((area (car (gopcaml-find-defun-start (point) (line-number-at-pos))))) 411 | (if area 412 | (progn (goto-char area)) 413 | nil))) 414 | 415 | (defun gopcaml-end-defun () 416 | "Move forwards to the end of the defun." 417 | (interactive) 418 | (let ((area (car (gopcaml-find-defun-end (point) (line-number-at-pos))))) 419 | (if area 420 | (progn (goto-char area)) 421 | nil))) 422 | 423 | (defun gopcaml-goto-nearest-letdef () 424 | "Move backwards to the nearest letdef." 425 | (interactive) 426 | (let ((area (car (gopcaml-find-nearest-letdef (point) (line-number-at-pos))))) 427 | (if area 428 | (progn 429 | (push-mark) 430 | (goto-char area)) 431 | nil))) 432 | 433 | (defun gopcaml-goto-nearest-pattern () 434 | "Move backwards to the nearest letdef." 435 | (interactive) 436 | (let ((area (car (gopcaml-find-nearest-pattern (point) (line-number-at-pos))))) 437 | (if area 438 | (progn 439 | (push-mark) 440 | (goto-char area) 441 | ) 442 | nil))) 443 | 444 | (defun gopcaml-move-to-hole () 445 | "Move to (??) from the current point." 446 | (interactive) 447 | (let ((end (car (gopcaml-find-defun-end (point) (line-number-at-pos)))) (curr (point))) 448 | (when (and end (search-forward "(??)" end t)) 449 | (if (equal (point) (+ curr 4)) (gopcaml-move-to-hole) (backward-char 4)) 450 | ) 451 | )) 452 | 453 | (defun gopcaml-move-backward-to-hole () 454 | "Move to (??) backward from the current point." 455 | (interactive) 456 | (let ((start (car (gopcaml-find-defun-start (point) (line-number-at-pos)))) (curr (point))) 457 | (when (and start (search-backward "(??)" start t)) 458 | (if (equal (point) curr) (gopcaml-move-to-hole)) 459 | ) 460 | )) 461 | 462 | 463 | (defun gopcaml-forward-list-full (selection-mode) 464 | "Move the zipper forwards (broadly from current point) in SELECTION-MODE." 465 | (interactive) 466 | (gopcaml-zipper-mode-and-move (lambda (initial) 467 | (move-gopcaml-zipper 468 | #'gopcaml-move-zipper-right 469 | 'forward 470 | initial) 471 | ) 472 | #'gopcaml-broadly-build-zipper 473 | selection-mode 474 | 'forward)) 475 | 476 | (defun gopcaml-forward-list () 477 | "Move the zipper forwards (broadly from current point)." 478 | (interactive) (gopcaml-forward-list-full nil)) 479 | 480 | (defun gopcaml-forward-list-selection () 481 | "Move the zipper forwards (broadly from current point)." 482 | (interactive) (gopcaml-forward-list-full t)) 483 | 484 | (defun gopcaml-backward-list-full (selection-mode) 485 | "Move the zipper backwards (broadly from current point) in SELECTION-MODE." 486 | (interactive) 487 | (gopcaml-zipper-mode-and-move (lambda (initial) 488 | (move-gopcaml-zipper 489 | #'gopcaml-move-zipper-left 490 | 'backward 491 | initial)) 492 | #'gopcaml-broadly-build-zipper 493 | selection-mode 494 | 'backward)) 495 | 496 | (defun gopcaml-backward-list () 497 | "Move the zipper backwards (broadly from current point)." 498 | (interactive) (gopcaml-backward-list-full nil)) 499 | 500 | (defun gopcaml-backward-list-selection () 501 | "Move the zipper backwards (broadly from current point)." 502 | (interactive) (gopcaml-backward-list-full t)) 503 | 504 | (defun gopcaml-backward-up-list-full (selection-mode) 505 | "Move the zipper up (from expression at point) in SELECTION-MODE." 506 | (interactive) 507 | (gopcaml-zipper-mode-and-move (lambda (initial) (move-gopcaml-zipper 508 | #'gopcaml-move-zipper-up 509 | nil 510 | initial)) 511 | nil 512 | selection-mode 513 | 'backward)) 514 | (defun gopcaml-backward-up-list () 515 | "Move the zipper up (from expression at point)." 516 | (interactive) (gopcaml-backward-up-list-full nil)) 517 | (defun gopcaml-backward-up-list-selection () 518 | "Move the zipper up (from expression at point)." 519 | (interactive) (gopcaml-backward-up-list-full t)) 520 | 521 | 522 | (defun gopcaml-down-list-full (selection-mode) 523 | "Move the zipper down (from expression at point) in SELECTION-MODE." 524 | (interactive) 525 | (gopcaml-zipper-mode-and-move (lambda (initial) (move-gopcaml-zipper 526 | #'gopcaml-move-zipper-down 527 | nil 528 | initial)) 529 | nil 530 | selection-mode 531 | 'forward)) 532 | (defun gopcaml-down-list () 533 | "Move the zipper dow (from expression at point)." 534 | (interactive) (gopcaml-down-list-full nil)) 535 | 536 | (defun gopcaml-down-list-selection () 537 | "Move the zipper down (from expression at point)." 538 | (interactive) (gopcaml-down-list-full t)) 539 | 540 | (defun gopcaml-forward-sexp-full (selection-mode &optional arg) 541 | "Move the zipper forward ARG times (from expression at point) in SELECTION-MODE." 542 | (interactive "^p") 543 | (if (equal arg (- 1)) 544 | (gopcaml-zipper-mode-and-move (lambda (initial) (move-gopcaml-zipper 545 | #'gopcaml-move-zipper-left 546 | 'backward 547 | initial)) 548 | nil 549 | selection-mode 550 | 'backward) 551 | (gopcaml-zipper-mode-and-move (lambda (initial) (move-gopcaml-zipper 552 | #'gopcaml-move-zipper-right 553 | 'forward 554 | initial)) 555 | nil 556 | selection-mode 557 | 'forward))) 558 | 559 | (defun gopcaml-forward-sexp (&optional arg) 560 | "Move the zipper down (from expression at point)." 561 | (interactive "p") (gopcaml-forward-sexp-full nil arg)) 562 | 563 | (defun gopcaml-forward-sexp-selection (&optional arg) 564 | "Move the zipper down (from expression at point)." 565 | (interactive "p") (gopcaml-forward-sexp-full t arg)) 566 | 567 | (defun gopcaml-backward-sexp-full (selection-mode &optional arg) 568 | "Move the zipper backwards (from expression at point) in SELECTION-MODE." 569 | (interactive "p") 570 | (gopcaml-zipper-mode-and-move (lambda (initial) (move-gopcaml-zipper 571 | #'gopcaml-move-zipper-left 572 | 'backward 573 | initial)) 574 | nil 575 | selection-mode 576 | 'backward)) 577 | 578 | (defun gopcaml-backward-sexp (&optional arg) 579 | "Move the zipper down (from expression at point)." 580 | (interactive "p") 581 | (gopcaml-backward-sexp-full nil arg)) 582 | 583 | (defun gopcaml-backward-sexp-selection (&optional arg) 584 | "Move the zipper down (from expression at point)." 585 | (interactive "p") (gopcaml-backward-sexp-full t arg)) 586 | 587 | (defun gopcaml-ensure-space-between-backward () 588 | "Ensures space between points." 589 | (interactive) 590 | (let ((start (point)) end 591 | (start-line (line-number-at-pos)) 592 | end-line 593 | (indent (current-column)) 594 | ) 595 | (skip-chars-backward " \n\t") 596 | (setq end (point)) 597 | (setq end-line (line-number-at-pos)) 598 | (delete-region start end) 599 | (insert "\n") 600 | (insert "\n") 601 | (insert (make-string indent 32)) 602 | (list (- (point) end) (- start end) 603 | (- (line-number-at-pos) end-line) 604 | (- start-line end-line)) 605 | )) 606 | 607 | (defun gopcaml-ensure-space-between-forward () 608 | "Ensures space between points." 609 | (interactive) 610 | (let ((start (point)) end 611 | (start-line (line-number-at-pos)) 612 | end-line 613 | indent 614 | ) 615 | (skip-chars-forward " \n\t") 616 | (setq indent (current-column)) 617 | (setq end (point)) 618 | (setq end-line (line-number-at-pos)) 619 | (delete-region start end) 620 | (insert "\n") 621 | (insert "\n") 622 | (insert (make-string indent 32)) 623 | (list (- start (point)) (- start end) 624 | (- start-line (line-number-at-pos)) (- start-line end-line)) 625 | )) 626 | 627 | (defun gopcaml-zipper-ensure-space () 628 | "Ensures-spacing between current element." 629 | (if (and (car (gopcaml-zipper-is-top-level)) (car (gopcaml-zipper-is-top-level-parent))) 630 | (let 631 | ((area (car (gopcaml-retrieve-zipper-bounds))) 632 | start end 633 | pre-change 634 | post-change) 635 | (when area 636 | (setq start (car area)) 637 | (setq end (cadr area)) 638 | (goto-char end) 639 | (setq post-change (gopcaml-ensure-space-between-forward)) 640 | (setq post-change 641 | (list 642 | (- (car post-change) (cadr post-change)) 643 | (- (caddr post-change) (cadddr post-change) )) 644 | ) 645 | (goto-char start) 646 | (setq pre-change (gopcaml-ensure-space-between-backward)) 647 | (setq pre-change 648 | (list 649 | (- (cadr pre-change) (car pre-change)) 650 | (- (cadddr pre-change) (caddr pre-change)))) 651 | (setq area (car (gopcaml-zipper-space-update 652 | (car pre-change) (cadr pre-change) 653 | (car post-change) (cadr post-change)))) 654 | (when area 655 | (move-overlay gopcaml-zipper-overlay (car area) (cadr area)) 656 | t))) 657 | nil)) 658 | 659 | (defun gopcaml-zipper-type () 660 | "Type region enclosed by zipper." 661 | (interactive) 662 | (when gopcaml-zipper-overlay 663 | (let ((start (overlay-start gopcaml-zipper-overlay)) 664 | (end (overlay-end gopcaml-zipper-overlay))) 665 | (lexical-let* 666 | ((substring (buffer-substring-no-properties start end)) 667 | (on-success (lambda (type) (merlin--type-display nil type nil))) 668 | (on-error (lambda (err) 669 | (let ((msg (assoc 'message err)) 670 | (typ (assoc type err))) 671 | (cond ((and typ (equal (cdr typ) "parser")) 672 | (message "Error: the content of the region failed to parse.")) 673 | (msg (message "Error: %s" (cdr msg))) 674 | (t 675 | (message "Unexpected error"))))))) 676 | (merlin--type-expression substring on-success on-error)) 677 | ))) 678 | 679 | (defun gopcaml-zipper-kill-region () 680 | "Kill the current item using the zipper." 681 | (interactive) 682 | (let ((area (car (gopcaml-begin-zipper-delete))) start end (buf-name (buffer-name))) 683 | (when area 684 | (setq start (car area)) 685 | (setq end (cadr area)) 686 | (kill-region start end) 687 | (setq area (car (gopcaml-retrieve-zipper-bounds))) 688 | (move-overlay gopcaml-zipper-overlay (car area) (cadr area)) 689 | (goto-char (car area))))) 690 | 691 | (defun gopcaml-zipper-move-vertical (move-fn) 692 | "Insert a let-def using the zipper MOVE-FN." 693 | (interactive) 694 | (let (area insert-pos start end text) 695 | (setq area (car (funcall move-fn))) 696 | (when area 697 | (setq insert-pos (car area)) 698 | (setq start (cadr area)) 699 | (setq end (caddr area)) 700 | (setq text (buffer-substring-no-properties start end)) 701 | (delete-region start end) 702 | (goto-char insert-pos) 703 | (insert "\n\n") 704 | (insert text) 705 | (insert "\n") 706 | (setq area (car (gopcaml-retrieve-zipper-bounds))) 707 | (move-overlay gopcaml-zipper-overlay (car area) (cadr area)) 708 | (goto-char (car area)) 709 | ) 710 | )) 711 | 712 | (defun gopcaml-zipper-move-up () 713 | "Move the zipper element up." 714 | (interactive) 715 | (gopcaml-zipper-move-vertical #'gopcaml-zipper-move-elem-up)) 716 | 717 | (defun gopcaml-zipper-move-down () 718 | "Move the zipper down." 719 | (interactive) 720 | (gopcaml-zipper-move-vertical #'gopcaml-zipper-move-elem-down)) 721 | 722 | (defun gopcaml-zipper-insert-letdef () 723 | "Attempt to insert a let-def using the zipper." 724 | (interactive) 725 | (let (area (column (current-column)) text start-pos) 726 | (setq area (car (gopcaml-zipper-insert-let-def-start column))) 727 | (setq text (car area)) 728 | (setq start-pos (cdr area)) 729 | (goto-char start-pos) 730 | (insert "\n\n") 731 | (insert (make-string column 32)) 732 | (insert text) 733 | (insert "\n") 734 | (setq area (car (gopcaml-retrieve-zipper-bounds))) 735 | (move-overlay gopcaml-zipper-overlay (car area) (cadr area)) 736 | (goto-char (car area)) 737 | )) 738 | 739 | (defun gopcaml-copy-region () 740 | "Copy region encompassed by the zipper." 741 | (when gopcaml-zipper-overlay 742 | (let ((start (overlay-start gopcaml-zipper-overlay)) 743 | (end (overlay-end gopcaml-zipper-overlay)) 744 | text) 745 | (setq text (buffer-substring-no-properties start end)) 746 | (copy-region-as-kill start end) 747 | (message "copied \"%s\" to kill-ring" (truncate-string-to-width 748 | text 40 nil nil t))))) 749 | 750 | (defun gopcaml-mode-insert-type-hole () 751 | "Insert a type hole at the cursor." 752 | (interactive) 753 | (insert "(??)")) 754 | 755 | (defun gopcaml-zipper-swap (transform-fn) 756 | "Swap current text using output from zipper function TRANSFORM-FN." 757 | (let ((area (car (funcall transform-fn))) 758 | region1-start 759 | region1-end 760 | region2-start 761 | region2-end) 762 | (when area 763 | (setq region1-start (car area)) 764 | (setq region1-end (car (cdr area))) 765 | (setq region2-start (car (cdr (cdr area)))) 766 | (setq region2-end (car (cdr (cdr (cdr area))))) 767 | (let ((region1-str (buffer-substring region1-start region1-end)) 768 | (region2-str (buffer-substring region2-start region2-end))) 769 | (when (< region2-start region1-start) 770 | (cl-psetq region1-start region2-start 771 | region1-end region2-end 772 | region1-str region2-str 773 | region2-start region1-start 774 | region2-end region1-end 775 | region2-str region1-str)) 776 | (progn 777 | (delete-region region2-start region2-end) 778 | (goto-char region2-start) 779 | (insert region1-str)) 780 | (progn 781 | (delete-region region1-start region1-end) 782 | (goto-char region1-start) 783 | (insert region2-str))) 784 | (setq area (car (gopcaml-retrieve-zipper-bounds))) 785 | (move-overlay gopcaml-zipper-overlay (car area) (cadr area)) 786 | (goto-char (car area)) 787 | ))) 788 | 789 | (defun gopcaml-zipper-transpose () 790 | "Transpose text using zipper." 791 | (interactive) 792 | (let ((area 793 | (if (not gopcaml-zipper) 794 | ;; build zipper aronud point 795 | (let 796 | ((area 797 | (car (gopcaml-build-zipper (point) (line-number-at-pos) nil))) 798 | start end overlay) 799 | ;; if successfull then perform operation 800 | (if area 801 | (progn 802 | (setq start (car area)) 803 | (setq end (cadr area)) 804 | (setq overlay (make-overlay start end)) 805 | ;; (overlay-put overlay 'face 'gopcaml-selection-face) 806 | (overlay-put overlay 'face 'gopcaml-zipper-face) 807 | (overlay-put overlay 'gopcaml-kind 'zipper) 808 | (setq gopcaml-zipper-overlay overlay) 809 | (setq gopcaml-zipper-mode-quit 810 | (set-transient-map 811 | gopcaml-zipper-mode-map 812 | t #'gopcaml-on-exit-zipper-mode)) 813 | area) 814 | (gopcaml-delete-zipper) 815 | nil)) 816 | ;; otherwise just perfom operation 817 | (car (gopcaml-retrieve-zipper-bounds)) 818 | )) 819 | start end curr) 820 | (if area 821 | (progn 822 | (setq curr (point)) 823 | (setq start (car area)) 824 | (setq end (cadr area)) 825 | (cond 826 | ((and start end (equal start curr)) 827 | (gopcaml-zipper-swap #'gopcaml-begin-zipper-swap-backwards) 828 | (gopcaml-move-zipper-right) 829 | (setq area (car (gopcaml-retrieve-zipper-bounds)))) 830 | 831 | ((and start end (equal end curr)) 832 | (gopcaml-zipper-swap #'gopcaml-begin-zipper-swap-forwards) 833 | (setq area (car (gopcaml-retrieve-zipper-bounds)))) 834 | (t 835 | ;; failed to set area 836 | (setq area nil) 837 | (gopcaml-on-exit-zipper-mode) 838 | nil)) 839 | (when area 840 | (move-overlay gopcaml-zipper-overlay (car area) (cadr area)) 841 | (goto-char (cadr area)) 842 | t)) 843 | nil))) 844 | 845 | (defun gopcaml-zipper-move-forwards () 846 | "Move current element forwards at the same level." 847 | (interactive) 848 | (gopcaml-zipper-swap #'gopcaml-begin-zipper-swap-forwards)) 849 | 850 | (defun gopcaml-zipper-move-backwards () 851 | "Move current element backwards at the same level." 852 | (interactive) 853 | (gopcaml-zipper-swap #'gopcaml-begin-zipper-swap-backwards)) 854 | 855 | (defun gopcaml-state-filter (cmd) 856 | "Determines whether a CMD can be carried out in current Gopcaml mode state." 857 | (when (and gopcaml-state(gopcaml-state-available-filter)) 858 | cmd)) 859 | 860 | (defun gopcaml-zipper-use-current-and-quit (fn) 861 | "Execute FN on region enclosing the selected zipper item and exits zipper mode." 862 | (interactive) 863 | (when (and gopcaml-zipper-overlay gopcaml-zipper-mode-quit) 864 | (let ((area (car (gopcaml-retrieve-zipper-bounds)))) 865 | (when area 866 | (funcall fn (car area) (cadr area)) 867 | ;; sometimes the function being called will call operations 868 | ;; that end up quitting the transient mode automatically, so 869 | ;; we don't need to do anything 870 | (if gopcaml-zipper-mode-quit 871 | (funcall gopcaml-zipper-mode-quit)))))) 872 | 873 | (defun gopcaml-zipper-kill () 874 | "Deletes the current item and exits zipper mode." 875 | (interactive) 876 | (gopcaml-zipper-use-current-and-quit #'kill-region)) 877 | 878 | ;;;; Mode maps 879 | (defvar gopcaml-zipper-mode-map 880 | (let ((gopcaml-map (make-sparse-keymap))) 881 | (define-key gopcaml-map (kbd "C-M-f") 882 | '(menu-item "" gopcaml-forward-sexp )) 883 | (define-key gopcaml-map (kbd "C-M-b") 884 | '(menu-item "" gopcaml-backward-sexp)) 885 | (define-key gopcaml-map (kbd "C-M-q") 886 | #'gopcaml-indent-current-sexp) 887 | (define-key gopcaml-map (kbd "C-M-u") 888 | '(menu-item "" gopcaml-backward-up-list)) 889 | (define-key gopcaml-map (kbd "C-M-S-u") 890 | '(menu-item "" gopcaml-zipper-move-up)) 891 | (define-key gopcaml-map (kbd "C-M-d") 892 | '(menu-item "" gopcaml-down-list )) 893 | (define-key gopcaml-map (kbd "C-M-S-d") 894 | '(menu-item "" gopcaml-zipper-move-down)) 895 | (define-key gopcaml-map (kbd "C-M-n") 896 | '(menu-item "" gopcaml-forward-list)) 897 | (define-key gopcaml-map (kbd "C-M-p") 898 | '(menu-item "" gopcaml-backward-list)) 899 | (define-key gopcaml-map (kbd "C-M-w") 900 | #'gopcaml-zipper-kill) 901 | (define-key gopcaml-map (kbd "C-w") 902 | #'gopcaml-zipper-kill) 903 | (define-key gopcaml-map (kbd "M-w") 904 | '(menu-item "" (lambda () (interactive) (gopcaml-copy-region)) 905 | )) 906 | (define-key gopcaml-map (kbd "C-M-S-n") 907 | '(menu-item "" (lambda () (interactive) (gopcaml-zipper-move-forwards)) 908 | )) 909 | (define-key gopcaml-map (kbd "C-M-S-f") 910 | '(menu-item "" (lambda () (interactive) (gopcaml-zipper-move-forwards)) 911 | )) 912 | (define-key gopcaml-map (kbd "C-M-S-p") 913 | '(menu-item "" (lambda () (interactive) (gopcaml-zipper-move-backwards)) 914 | )) 915 | (define-key gopcaml-map (kbd "C-M-S-b") 916 | '(menu-item "" (lambda () (interactive) (gopcaml-zipper-move-backwards)) 917 | )) 918 | (define-key gopcaml-map (kbd "C-M-t") 919 | '(menu-item "" (lambda () (interactive) (gopcaml-zipper-transpose)) 920 | )) 921 | (define-key gopcaml-map (kbd "M-SPC") 922 | '(menu-item "" (lambda () (interactive) (gopcaml-zipper-ensure-space)))) 923 | (define-key gopcaml-map (kbd "C-M-SPC") 924 | '(menu-item "" (lambda () (interactive) (gopcaml-zipper-ensure-space)))) 925 | 926 | gopcaml-map) 927 | "Map used when in zipper mode. ari ari!") 928 | 929 | (defvar gopcaml-selection-zipper-mode-map 930 | (let ((gopcaml-map (make-sparse-keymap))) 931 | (define-key gopcaml-map (kbd "C-M-S-f") 932 | '(menu-item "" gopcaml-forward-sexp-selection)) 933 | (define-key gopcaml-map (kbd "C-M-S-b") 934 | '(menu-item "" gopcaml-backward-sexp-selection)) 935 | 936 | (define-key gopcaml-map (kbd "C-M-S-u") 937 | '(menu-item "" gopcaml-backward-up-list-selection)) 938 | (define-key gopcaml-map (kbd "C-M-S-d") 939 | '(menu-item "" gopcaml-down-list-selection)) 940 | 941 | (define-key gopcaml-map (kbd "C-M-S-n") 942 | '(menu-item "" gopcaml-forward-list-selection)) 943 | (define-key gopcaml-map (kbd "C-M-S-p") 944 | '(menu-item "" gopcaml-backward-list-selection)) 945 | gopcaml-map) 946 | "Map used when in zipper mode for selections. ari ari!") 947 | 948 | (defvar gopcaml-mark-zipper-mode-map 949 | (let ((gopcaml-map (make-sparse-keymap))) 950 | (define-key gopcaml-map 951 | (kbd "C-M-@") 952 | #'gopcaml-zipper-mark-mode) 953 | (define-key gopcaml-map 954 | (kbd "C-M-SPC") 955 | #'gopcaml-zipper-mark-mode) 956 | gopcaml-map) 957 | "Map used when in zipper mode for marking expressions. ari ari!") 958 | 959 | (defun gopcaml-on-exit-zipper-mode () 960 | "Exit gopcaml-zipper-mode." 961 | (gopcaml-delete-zipper) 962 | (delete-overlay gopcaml-zipper-overlay) 963 | (setq gopcaml-zipper-overlay nil) 964 | (setq gopcaml-zipper-mode-quit nil)) 965 | 966 | ;; graciously taken from https://emacs.stackexchange.com/questions/12532/buffer-local-idle-timer 967 | (defun run-with-local-idle-timer (secs repeat function &rest args) 968 | "`run-with-idle-timer' but always run in the `current-buffer'. 969 | Cancels itself, if this buffer was killed. 970 | SECS is the periodicity of the timer. 971 | REPEAT dictates whether the timer should be called repeatedly. 972 | FUNCTION is the function to call on timer. 973 | ARGS are parameters to pass to the function." 974 | (let* (;; Chicken and egg problem. 975 | (fns (make-symbol "local-idle-timer")) 976 | (timer (apply 'run-with-idle-timer secs repeat fns args)) 977 | (fn `(lambda (&rest args) 978 | (if (not (buffer-live-p ,(current-buffer))) 979 | (cancel-timer ,timer) 980 | (with-current-buffer ,(current-buffer) 981 | (apply (function ,function) args)))))) 982 | (fset fns fn) 983 | timer)) 984 | 985 | (defun gopcaml-before-change-remove-type-hole (beginning end) 986 | "Before inserting text, attempt to remove type holes. 987 | BEGINNING is the start of the edited text region. 988 | END is the end of the edited text region." 989 | (let ( (point (point)) element) 990 | (when (and (equal beginning end) (< (+ point 4) (point-max))) 991 | (setq element (buffer-substring-no-properties point (+ point 4))) 992 | (if (equal "(??)" element) 993 | (delete-region point (+ point 4)) 994 | )))) 995 | 996 | 997 | (defun gopcaml-type-hole-needed () 998 | "Check whether the current expression expansion needs a type hole." 999 | (save-excursion 1000 | (skip-chars-forward " \t\n") 1001 | (looking-at-p "\\(|\\|end\\|module\\|val\\|type\\)") 1002 | ) 1003 | ) 1004 | 1005 | (defun gopcaml-list-free-variables (start end) 1006 | "List free variables in region from START to END." 1007 | (interactive "^r") 1008 | (let ((text (buffer-substring-no-properties start end)) 1009 | bounds) 1010 | (setq bounds (car (gopcaml-find-extract-scope text start end))) 1011 | (when (and bounds) 1012 | (gopcaml-temporarily-highlight-region bounds)))) 1013 | 1014 | (defun gopcaml-list-pattern-scopes () 1015 | "Highlight all patterns in the current item." 1016 | (interactive) 1017 | (let ((mbounds (gopcaml-find-patterns-in-scope (point)))) 1018 | (when mbounds 1019 | (gopcaml-temporarily-highlight-multiple-region mbounds)))) 1020 | 1021 | (defun match-seq (pattern beg end) 1022 | "Return a list of all ocurrances of PATTERN in region from BEG to END." 1023 | (let (matches) 1024 | (save-excursion 1025 | (goto-char beg) 1026 | (save-match-data 1027 | (while (search-forward pattern end t) 1028 | (push (cons (match-beginning 0) (match-end 0)) matches) 1029 | (goto-char (match-end 0))) 1030 | matches)))) 1031 | 1032 | (defun highlight-occurrances-in-region (beg end) 1033 | "Highlight all ocurrances of a string in the region from BEG to END." 1034 | (interactive "^r") 1035 | (gopcaml-temporarily-highlight-multiple-region (match-seq (read-string "Search string:") beg end)) 1036 | ) 1037 | 1038 | ;;;; Setup keybindings 1039 | 1040 | (define-key gopcaml-mode-map (kbd "TAB") #'gopcaml-move-to-hole) 1041 | (define-key gopcaml-mode-map (kbd "") #'gopcaml-move-backward-to-hole) 1042 | (define-key gopcaml-mode-map (kbd "M-RET") #'gopcaml-mode-insert-type-hole) 1043 | (define-key gopcaml-mode-map (kbd "C-M-u") '(menu-item "" gopcaml-backward-up-list 1044 | :filter gopcaml-state-filter)) 1045 | (define-key gopcaml-mode-map (kbd "C-M-q") '(menu-item "" gopcaml-indent-current-sexp 1046 | :filter gopcaml-state-filter)) 1047 | (define-key gopcaml-mode-map (kbd "C-M-d") '(menu-item "" gopcaml-down-list 1048 | :filter gopcaml-state-filter)) 1049 | (define-key gopcaml-mode-map (kbd "C-M-n") '(menu-item "" gopcaml-forward-list 1050 | :filter gopcaml-state-filter)) 1051 | (define-key gopcaml-mode-map (kbd "C-M-p") '(menu-item "" gopcaml-backward-list 1052 | :filter gopcaml-state-filter)) 1053 | (define-key gopcaml-mode-map (kbd "C-M-t") '(menu-item "" gopcaml-zipper-transpose 1054 | :filter gopcaml-state-filter)) 1055 | (define-key gopcaml-mode-map (kbd "C-M-S-u") '(menu-item "" gopcaml-backward-up-list-selection 1056 | :filter gopcaml-state-filter)) 1057 | (define-key gopcaml-mode-map (kbd "C-M-S-d") '(menu-item "" gopcaml-down-list-selection 1058 | :filter gopcaml-state-filter)) 1059 | (define-key gopcaml-mode-map (kbd "C-M-S-n") '(menu-item "" gopcaml-forward-list-selection 1060 | :filter gopcaml-state-filter)) 1061 | (define-key gopcaml-mode-map (kbd "C-M-S-p") '(menu-item "" gopcaml-backward-list-selection 1062 | :filter gopcaml-state-filter)) 1063 | 1064 | (define-key merlin-mode-map (kbd "C-c C-o") '(menu-item "" gopcaml-goto-nearest-letdef 1065 | :filter gopcaml-state-filter)) 1066 | 1067 | (define-key merlin-mode-map (kbd "C-c C-p") '(menu-item "" gopcaml-goto-nearest-pattern 1068 | :filter gopcaml-state-filter)) 1069 | 1070 | (define-key gopcaml-mode-map (kbd "C-M-@") '(menu-item "" gopcaml-zipper-mark-mode 1071 | :filter gopcaml-state-filter)) 1072 | (define-key gopcaml-mode-map (kbd "C-M-SPC") '(menu-item "" gopcaml-zipper-mark-mode 1073 | :filter gopcaml-state-filter)) 1074 | 1075 | ;;; Mode initialization functions 1076 | ;; As the mode itself is defined within the dynamic module, the code below sets up the buffer using a hook 1077 | (defun gopcaml-setup-bindings () 1078 | "Setup bindings for gopcaml-mode." 1079 | (setq-local end-of-defun-function #'gopcaml-end-defun) 1080 | (setq-local beginning-of-defun-function #'gopcaml-beginning-defun) 1081 | 1082 | ;; backup bindings (if smartparens not installed) 1083 | (unless (lookup-key gopcaml-mode-map (kbd "C-M-f")) 1084 | (define-key gopcaml-mode-map (kbd "C-M-f") '(menu-item "" gopcaml-forward-sexp 1085 | :filter gopcaml-state-filter))) 1086 | 1087 | (unless (lookup-key gopcaml-mode-map (kbd "C-M-b")) 1088 | (define-key gopcaml-mode-map (kbd "C-M-b") '(menu-item "" gopcaml-backward-sexp 1089 | :filter gopcaml-state-filter))) 1090 | (unless (lookup-key gopcaml-mode-map (kbd "C-M-S-f")) 1091 | (define-key gopcaml-mode-map (kbd "C-M-S-f") '(menu-item "" gopcaml-forward-sexp-selection 1092 | :filter gopcaml-state-filter))) 1093 | 1094 | (unless (lookup-key gopcaml-mode-map (kbd "C-M-S-b")) 1095 | (define-key gopcaml-mode-map (kbd "C-M-S-b") '(menu-item "" gopcaml-backward-sexp-selection 1096 | :filter gopcaml-state-filter))) 1097 | 1098 | (setq-local forward-sexp-function nil) 1099 | (add-hook 'after-change-functions #'gopcaml-update-dirty-region) 1100 | (add-hook 'before-change-functions #'gopcaml-before-change-remove-type-hole) 1101 | (setq gopcaml-update-timer 1102 | (run-with-local-idle-timer gopcaml-rebuild-delay t 1103 | (lambda () 1104 | (when gopcaml-state (gopcaml-ensure-updated-state))))) 1105 | (if (and (boundp 'gopcaml-dev-mode) gopcaml-dev-mode 1106 | (boundp 'gopcaml-dev-mode-filemap) gopcaml-dev-mode-filemap 1107 | (boundp 'gopcaml-dev-mode-file) gopcaml-dev-mode-file) 1108 | (progn 1109 | (puthash gopcaml-dev-mode-file t gopcaml-dev-mode-filemap)))) 1110 | 1111 | (defun gopcaml-quit () 1112 | "Quit gopcaml-mode and tear down its timers and bindings." 1113 | (interactive) 1114 | (setq after-change-functions 1115 | (remove #'gopcaml-update-dirty-region after-change-functions)) 1116 | (setq before-change-functions 1117 | (remove #'gopcaml-before-change-remove-type-hole before-change-functions)) 1118 | (if gopcaml-update-timer 1119 | (progn "cancelling gopcaml-update-timer" (cancel-timer gopcaml-update-timer))) 1120 | (setq gopcaml-update-timer nil) 1121 | (setq gopcaml-state nil) 1122 | (setq gopcaml-zipper nil) 1123 | (fundamental-mode)) 1124 | 1125 | (defun gopcaml-setup-hook () 1126 | "Initialize gopcaml-mode." 1127 | (unless (gopcaml-is-excluded-current-file) 1128 | (gopcaml-setup-bindings))) 1129 | 1130 | (add-hook 'gopcaml-mode-hook #'gopcaml-setup-hook) 1131 | 1132 | 1133 | (provide 'gopcaml-mode) 1134 | 1135 | ;; optional dependencies 1136 | (eval-after-load 'smartparens '(require 'gopcaml-smartparens)) 1137 | (eval-after-load 'multiple-cursors '(require 'gopcaml-multiple-cursors)) 1138 | ;;; gopcaml-mode.el ends here 1139 | -------------------------------------------------------------------------------- /gopcaml-mode.opam: -------------------------------------------------------------------------------- 1 | # This file is generated by dune, edit dune-project instead 2 | opam-version: "2.0" 3 | build: [ 4 | ["dune" "subst"] {pinned} 5 | ["dune" "build" "-p" name "-j" jobs] 6 | ["dune" "runtest" "-p" name "-j" jobs] {with-test} 7 | ["dune" "build" "-p" name "@doc"] {with-doc} 8 | ] 9 | maintainer: ["kirang@comp.nus.edu.sg"] 10 | authors: ["Kiran Gopinathan"] 11 | bug-reports: "https://gitlab.com/gopiandcode/gopcaml-mode/issues" 12 | homepage: "https://gitlab.com/gopiandcode/gopcaml-mode" 13 | license: "GPL-3.0-only" 14 | version: "0.0.6" 15 | dev-repo: "git+https://gitlab.com/gopiandcode/gopcaml-mode.git" 16 | synopsis: 17 | "Ultimate Ocaml editing plugin, providing advanced structural editing, movement and analysis in Emacs" 18 | description: 19 | "Gopcaml-mode is a plugin for emacs for editing OCaml code. It aims to extend existing Emacs editing experience to closer match the features in modern IDEs." 20 | depends: [ 21 | "merlin" {>= "2.5.0"} 22 | "ocp-indent" {>= "1.0.0"} 23 | "ocaml" {>= "4.08.0"} 24 | "core" {>= "0.13.0"} 25 | "ppx_deriving" {>= "4.4"} 26 | "ocaml-migrate-parsetree" {>= "2.1.0"} 27 | "ecaml" {>= "0.13.0"} 28 | ] 29 | -------------------------------------------------------------------------------- /gopcaml-multiple-cursors.el: -------------------------------------------------------------------------------- 1 | ;;; gopcaml-multiple-cursors.el --- Support for multi-cursors in Gopcaml mode -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2020 Kiran Gopinathan 4 | 5 | ;; Author: Kiran Gopinathan 6 | ;; Keywords: languages, tools 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; 24 | 25 | ;;; Code: 26 | 27 | (require 'multiple-cursors) 28 | 29 | (defun gopcaml-extract-expression (start end) 30 | "Attempt to extract the expression in the current region START END." 31 | (interactive "^r") 32 | (when (and gopcaml-state (gopcaml-state-available-filter) (< (mc/num-cursors) 2)) 33 | (let ((text (buffer-substring-no-properties start end)) 34 | bounds matches marks master) 35 | (setq bounds (car (gopcaml-find-extract-scope text start end))) 36 | (when (and bounds) 37 | ;; retrieve list of matches in scope 38 | (setq matches (match-seq text (car bounds) (cdr bounds))) 39 | ;; find which matches are valid 40 | (setq matches (gopcaml-find-valid-matches (car bounds) matches (car bounds) (cdr bounds))) 41 | (when matches 42 | (push-mark) 43 | ;; now we have a list of valid matches and a point to insert them 44 | ;; convert each match to a list of markers 45 | (dolist (match matches) 46 | (push (cons 47 | (set-marker (make-marker) (+ (car match) 1)) 48 | (set-marker (make-marker) (cdr match)) 49 | ) marks) 50 | ) 51 | ;; now ready to edit 52 | (goto-char (car bounds)) 53 | (setq text (string-join (list text " in\n" (make-string (current-column) 32)) "") ) 54 | (insert (format "let = %s" text)) 55 | 56 | ;; move to insert point 57 | (goto-char (+ (car bounds) 4)) 58 | (setq master (point)) 59 | (push-mark master) 60 | ;; remove fake cursors if present 61 | (mc/remove-fake-cursors) 62 | (mc/save-excursion 63 | ;; delete all the ocurrances 64 | (dolist (mark marks) 65 | (let ((start (car mark)) (end (cdr mark))) 66 | ;; move to start of ocurrance 67 | (push-mark (-(marker-position start) 1)) 68 | (exchange-point-and-mark) 69 | ;; delete ocurrance 70 | (delete-region 71 | (- (marker-position start) 1) (marker-position end)) 72 | ;; create cursor at the point 73 | (mc/create-fake-cursor-at-point) 74 | ;; clean up the markers 75 | (set-marker start nil) 76 | (set-marker end nil) 77 | ) 78 | )) 79 | ;; finally enable multiple-cursors-mode 80 | (mc/maybe-multiple-cursors-mode) 81 | ) 82 | ) 83 | )) 84 | ) 85 | (defun gopcaml-zipper-extract-expression () 86 | "Extracts the current item and exits zipper mode." 87 | (interactive) 88 | (gopcaml-zipper-use-current-and-quit #'gopcaml-extract-expression)) 89 | 90 | 91 | (define-key gopcaml-mode-map (kbd "C-c C-e") #'gopcaml-extract-expression) 92 | (define-key merlin-mode-map (kbd "C-c C-e") #'gopcaml-extract-expression) 93 | (define-key gopcaml-zipper-mode-map (kbd "C-c C-e") #'gopcaml-zipper-extract-expression) 94 | 95 | 96 | (provide 'gopcaml-multiple-cursors) 97 | ;;; gopcaml-multiple-cursors.el ends here 98 | 99 | -------------------------------------------------------------------------------- /gopcaml-smartparens.el: -------------------------------------------------------------------------------- 1 | ;;; gopcaml-smartparens.el --- Support for smartparens in Gopcaml mode -*- lexical-binding: t; -*- 2 | 3 | ;; Copyright (C) 2020 Kiran Gopinathan 4 | 5 | ;; Author: Kiran Gopinathan 6 | ;; Keywords: tools, languages 7 | 8 | ;; This program is free software; you can redistribute it and/or modify 9 | ;; it under the terms of the GNU General Public License as published by 10 | ;; the Free Software Foundation, either version 3 of the License, or 11 | ;; (at your option) any later version. 12 | 13 | ;; This program is distributed in the hope that it will be useful, 14 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 15 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 16 | ;; GNU General Public License for more details. 17 | 18 | ;; You should have received a copy of the GNU General Public License 19 | ;; along with this program. If not, see . 20 | 21 | ;;; Commentary: 22 | 23 | ;; 24 | 25 | ;;; Code: 26 | 27 | (require 'smartparens) 28 | 29 | (defun gopcaml-state-sexp-filter (cmd) 30 | "Determines whether a CMD can be carried out in current Gopcaml mode state 31 | or whether a smart-parens based operation is more suitable." 32 | (cond 33 | ;; if we're looking at a opening or closing parens - smart parens 34 | ;; is better 35 | ((or 36 | (save-match-data 37 | (sp--looking-back (sp--get-closing-regexp 38 | (sp--get-pair-list-context 'navigate)))) 39 | (save-match-data 40 | (sp--looking-at (sp--get-opening-regexp 41 | (sp--get-pair-list-context 'navigate)))) 42 | ) nil) 43 | ((and gopcaml-state (gopcaml-state-available-filter)) 44 | cmd 45 | ) 46 | ) 47 | ) 48 | 49 | (define-key gopcaml-mode-map (kbd "C-M-f") '(menu-item "" gopcaml-forward-sexp 50 | :filter gopcaml-state-sexp-filter)) 51 | 52 | (define-key gopcaml-mode-map (kbd "C-M-b") '(menu-item "" gopcaml-backward-sexp 53 | :filter gopcaml-state-sexp-filter)) 54 | (define-key gopcaml-mode-map (kbd "C-M-t") '(menu-item "" gopcaml-zipper-transpose 55 | :filter gopcaml-state-filter)) 56 | (define-key gopcaml-mode-map (kbd "C-M-S-f") '(menu-item "" gopcaml-forward-sexp-selection 57 | :filter gopcaml-state-sexp-filter)) 58 | (define-key gopcaml-mode-map (kbd "C-M-S-b") '(menu-item "" gopcaml-backward-sexp-selection 59 | :filter gopcaml-state-sexp-filter)) 60 | 61 | 62 | 63 | (provide 'gopcaml-smartparens) 64 | ;;; gopcaml-smartparens.el ends here 65 | -------------------------------------------------------------------------------- /gopcaml.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Ecaml 3 | 4 | let version = 0.3 5 | 6 | let gopcaml_version = "0.0.3" 7 | 8 | module Variables = struct 9 | 10 | let state_var = Buffer_local.defvar 11 | ("gopcaml-state" |> Symbol.intern) 12 | [%here] 13 | ~docstring:{| 14 | Holds gopcaml-mode state. 15 | |} 16 | ~type_: (Value.Type.option Gopcaml_state.State.ty) 17 | ~default_value:(None) 18 | () 19 | 20 | let zipper_var = Buffer_local.defvar 21 | ("gopcaml-zipper" |> Symbol.intern) 22 | [%here] 23 | ~docstring:{| 24 | Holds the zipper used to enable gopcaml-mode "zipper mode". 25 | |} 26 | ~type_: (Value.Type.option Gopcaml_state.State.Zipper.ty) 27 | ~default_value:(None) 28 | () 29 | 30 | end 31 | 32 | module Customizable = struct 33 | 34 | let gopcaml_group = 35 | Customization.Group.defgroup "gopcaml" 36 | [%here] 37 | ~docstring:{| 38 | Gopcaml mode customization 39 | |} 40 | ~parents:[] 41 | 42 | let ignored_extensions_var = Customization.defcustom 43 | ~show_form:true 44 | ("gopcaml-ignored-extensions" |> Symbol.intern) 45 | [%here] 46 | ~group:gopcaml_group 47 | ~docstring:{| 48 | List of extensions to be ignored and disable gopcaml-mode for. 49 | 50 | By default it is disabled on ocamllex and menhir files as they do not conform to the standard OCaml syntax. 51 | |} 52 | ~type_: (Value.Type.list Value.Type.string) 53 | ~customization_type:(Customization.Type.Repeat Customization.Type.String) 54 | ~standard_value:["mll"; "mly"] 55 | () 56 | 57 | let interface_extensions_var = Customization.defcustom 58 | ~show_form:true 59 | ("gopcaml-interface-extensions" |> Symbol.intern) 60 | [%here] 61 | ~group:gopcaml_group 62 | ~docstring:{| 63 | List of extensions to be automatically assumed to be interface files. 64 | |} 65 | ~type_: (Value.Type.list Value.Type.string) 66 | ~customization_type:(Customization.Type.Repeat Customization.Type.String) 67 | ~standard_value:["mli"] 68 | () 69 | 70 | 71 | let implementation_extensions_var = Customization.defcustom 72 | ~show_form:true 73 | ("gopcaml-implementation-extensions" |> Symbol.intern) 74 | [%here] 75 | ~group:gopcaml_group 76 | ~docstring:{| 77 | List of extensions to be automatically assumed to be implementation files. 78 | |} 79 | ~type_: (Value.Type.list Value.Type.string) 80 | ~customization_type:(Customization.Type.Repeat Customization.Type.String) 81 | ~standard_value:["ml"] 82 | () 83 | 84 | let messaging_level_var = Customization.defcustom 85 | ~show_form:true 86 | ("gopcaml-messaging-level" |> Symbol.intern) 87 | [%here] 88 | ~group:gopcaml_group 89 | ~docstring:{| 90 | Control the level of messages sent out by GopCaml-mode.Re 91 | 92 | Must be one of either 'debug, 'verbose, 'info, 'none. 93 | |} 94 | ~type_: (Logging.Level.ty) 95 | ~customization_type:(Logging.Level.custom_ty) 96 | ~standard_value:`info 97 | () 98 | 99 | end 100 | 101 | let define_functions () = 102 | defun 103 | ("gopcaml-version" |> Symbol.intern) 104 | [%here] 105 | ~docstring:{| 106 | Returns gopcaml version number. 107 | |} 108 | (Returns Value.Type.string_cached) 109 | (let open Defun.Let_syntax in 110 | return (Printf.sprintf "%s" gopcaml_version) 111 | ); 112 | defun 113 | ("gopcaml-set-file-type" |> Symbol.intern) 114 | [%here] 115 | ~docstring:{| 116 | Configure gopcaml to treat current buffer as FILE-TYPE 117 | |} 118 | (Returns Value.Type.unit) 119 | (let open Defun.Let_syntax in 120 | let%map_open file_type = required "file-type" Gopcaml_state.State.Filetype.ty in 121 | Gopcaml_state.set_gopcaml_file_type 122 | ~state_var:Variables.state_var 123 | file_type 124 | ); 125 | defun 126 | ("gopcaml-get-file-type" |> Symbol.intern) 127 | [%here] 128 | ~docstring:{| 129 | Retrieve gopcaml's stored file type for the current buffer. 130 | |} 131 | (Returns Value.Type.string) 132 | (let open Defun.Let_syntax in 133 | let%map_open getter = return (Gopcaml_state.get_gopcaml_file_type 134 | ~state_var:Variables.state_var) in 135 | (getter ())); 136 | defun 137 | ("gopcaml-state-available-filter" |> Symbol.intern) 138 | [%here] 139 | ~docstring:{| Check whether gopcaml state is available. |} 140 | (Returns Value.Type.bool) 141 | (let open Defun.Let_syntax in 142 | let%map_open getter = return (Gopcaml_state.check_gopcaml_state_available 143 | ~state_var:Variables.state_var) in 144 | (getter ())); 145 | defun 146 | ("gopcaml-update-dirty-region" |> Symbol.intern) 147 | [%here] 148 | ~docstring:{| 149 | Notify gopcaml-mode of change to dirty region. 150 | |} 151 | (Returns Value.Type.unit) 152 | (let open Defun.Let_syntax in 153 | let%map_open st = required "start" (Value.Type.int) 154 | and ed = required "end" (Value.Type.int) 155 | and len = required "length" (Value.Type.int) in 156 | Gopcaml_state.update_dirty_region ~state_var:Variables.state_var (st,ed,len) 157 | ); 158 | defun 159 | ("gopcaml-get-dirty-region" |> Symbol.intern) 160 | [%here] 161 | ~docstring:{| 162 | Retrieve gopcaml-mode's dirty region bounds. 163 | |} 164 | (Returns (Value.Type.option (Value.Type.tuple Value.Type.int Value.Type.int))) 165 | (let open Defun.Let_syntax in 166 | let%map_open getter = return (Gopcaml_state.get_dirty_region ~state_var:Variables.state_var) in 167 | getter () 168 | ); 169 | defun 170 | ("gopcaml-get-enclosing-structure-bounds" |> Symbol.intern) 171 | [%here] 172 | ~docstring:{| Retrieve a pair of points enclosing the structure item at the current point |} 173 | (Returns (Value.Type.option (Value.Type.list Position.type_))) 174 | (let open Defun.Let_syntax in 175 | let%map_open point = required "point" (Position.type_) in 176 | Gopcaml_state.retrieve_enclosing_structure_bounds 177 | ~state_var:Variables.state_var 178 | point 179 | |> Option.map ~f:(fun (a,b) -> [a;b]) 180 | ); 181 | defun 182 | ("gopcaml-get-enclosing-bounds" |> Symbol.intern) 183 | [%here] 184 | ~docstring:{| Retrieve a pair of points enclosing the expression at the current point |} 185 | (Returns (Value.Type.option (Value.Type.list Position.type_))) 186 | (let open Defun.Let_syntax in 187 | let%map_open point = required "point" (Position.type_) in 188 | Gopcaml_state.retrieve_enclosing_bounds 189 | ~state_var:Variables.state_var 190 | point 191 | |> Option.map ~f:(fun (a,b) -> [a; b]) 192 | ); 193 | defun 194 | ("gopcaml-ensure-updated-state" |> Symbol.intern) 195 | [%here] 196 | ~docstring:{| Ensure that the gopcaml-state is up to date. |} 197 | (Returns (Value.Type.unit)) 198 | (let open Defun.Let_syntax in 199 | let%map_open getter = return @@ Gopcaml_state.retrieve_gopcaml_state ~state_var:Variables.state_var in 200 | ignore (getter ()) 201 | ); 202 | defun 203 | ("gopcaml-build-zipper" |> Symbol.intern) 204 | [%here] 205 | ~docstring:{| Builds an ast zipper around the current point. |} 206 | (Returns (Value.Type.option (Value.Type.list Position.type_))) 207 | (let open Defun.Let_syntax in 208 | let%map_open point = required "point" (Position.type_) 209 | and line = required "line" Value.Type.int 210 | and direction = required "direction" (Value.Type.option Gopcaml_state.State.Direction.ty) in 211 | let direction = match direction with 212 | | None 213 | | Some (Forward) -> true 214 | | _ -> false in 215 | Gopcaml_state.build_zipper_enclosing_point 216 | ~direction 217 | ~state_var:Variables.state_var ~zipper_var:Variables.zipper_var point line 218 | |> Option.map ~f:(fun (a,b) -> [a; b]) 219 | ); 220 | defun 221 | ("gopcaml-broadly-build-zipper" |> Symbol.intern) 222 | [%here] 223 | ~docstring:{| Builds an ast zipper broadly around the current point. |} 224 | (Returns (Value.Type.option (Value.Type.list Position.type_))) 225 | (let open Defun.Let_syntax in 226 | let%map_open point = required "point" (Position.type_) 227 | and line = required "line" Value.Type.int 228 | and _direction = required "direction" (Value.Type.option Gopcaml_state.State.Direction.ty) in 229 | Gopcaml_state.build_zipper_broadly_enclosing_point 230 | ~state_var:Variables.state_var ~zipper_var:Variables.zipper_var point line 231 | |> Option.map ~f:(fun (a,b) -> [a; b]) 232 | ); 233 | defun 234 | ("gopcaml-delete-zipper" |> Symbol.intern) 235 | [%here] 236 | ~docstring:{| Deletes the zipper if it exists. |} 237 | (Returns Value.Type.unit) 238 | (let open Defun.Let_syntax in 239 | let%map_open op = return @@ Gopcaml_state.delete_zipper ~zipper_var:Variables.zipper_var in 240 | op () 241 | ); 242 | defun 243 | ("gopcaml-retrieve-zipper-bounds" |> Symbol.intern) 244 | [%here] 245 | ~docstring:{| Retrieves the bounds represented by the current zipper. |} 246 | (Returns (Value.Type.option (Value.Type.list Position.type_))) 247 | (let open Defun.Let_syntax in 248 | let%map_open op = 249 | return @@ Gopcaml_state.retrieve_zipper_bounds ~zipper_var:Variables.zipper_var in 250 | op () 251 | |> Option.map ~f:(fun (a,b) -> [a; b]) 252 | ); 253 | defun 254 | ("gopcaml-move-zipper-left" |> Symbol.intern) 255 | [%here] 256 | ~docstring:{| Moves the current zipper left and returns its bounds. |} 257 | (Returns (Value.Type.option (Value.Type.list Position.type_))) 258 | (let open Defun.Let_syntax in 259 | let%map_open op = 260 | return @@ Gopcaml_state.move_zipper_left ~zipper_var:Variables.zipper_var in 261 | op () 262 | |> Option.map ~f:(fun (a,b) -> [a; b]) 263 | ); 264 | defun 265 | ("gopcaml-move-zipper-right" |> Symbol.intern) 266 | [%here] 267 | ~docstring:{| Moves the current zipper right and returns its bounds. |} 268 | (Returns (Value.Type.option (Value.Type.list Position.type_))) 269 | (let open Defun.Let_syntax in 270 | let%map_open op = 271 | return @@ Gopcaml_state.move_zipper_right ~zipper_var:Variables.zipper_var in 272 | op () 273 | |> Option.map ~f:(fun (a,b) -> [a; b]) 274 | ); 275 | defun 276 | ("gopcaml-move-zipper-up" |> Symbol.intern) 277 | [%here] 278 | ~docstring:{| Moves the current zipper up and returns its bounds. |} 279 | (Returns (Value.Type.option (Value.Type.list Position.type_))) 280 | (let open Defun.Let_syntax in 281 | let%map_open op = 282 | return @@ Gopcaml_state.move_zipper_up ~zipper_var:Variables.zipper_var in 283 | op () 284 | |> Option.map ~f:(fun (a,b) -> [a; b]) 285 | ); 286 | defun 287 | ("gopcaml-move-zipper-down" |> Symbol.intern) 288 | [%here] 289 | ~docstring:{| Moves the current zipper down and returns its bounds. |} 290 | (Returns (Value.Type.option (Value.Type.list Position.type_))) 291 | (let open Defun.Let_syntax in 292 | let%map_open op = 293 | return @@ Gopcaml_state.move_zipper_down ~zipper_var:Variables.zipper_var in 294 | op () 295 | |> Option.map ~f:(fun (a,b) -> [a; b]) 296 | ); 297 | defun 298 | ("gopcaml-zipper-move-elem-up" |> Symbol.intern) 299 | [%here] 300 | ~docstring:{| Moves the current element up and returns the bounds to transform. |} 301 | (Returns (Value.Type.option (Value.Type.list Position.type_))) 302 | (let open Defun.Let_syntax in 303 | let%map_open op = 304 | return @@ Gopcaml_state.zipper_move_up ~zipper_var:Variables.zipper_var in 305 | op () 306 | |> Option.map ~f:(fun (a,(b,c)) -> [a; b; c]) 307 | ); 308 | defun 309 | ("gopcaml-zipper-is-top-level" |> Symbol.intern) 310 | [%here] 311 | ~docstring:{| Checks whether the item under the zipper is a top-level item. |} 312 | (Returns (Value.Type.option Value.Type.bool)) 313 | (let open Defun.Let_syntax in 314 | let%map_open op = 315 | return @@ Gopcaml_state.check_zipper_toplevel ~zipper_var:Variables.zipper_var in 316 | op () 317 | ); 318 | defun 319 | ("gopcaml-zipper-is-top-level-parent" |> Symbol.intern) 320 | [%here] 321 | ~docstring:{| Checks whether the item under the zipper has a top-level parent. |} 322 | (Returns (Value.Type.option Value.Type.bool)) 323 | (let open Defun.Let_syntax in 324 | let%map_open op = 325 | return @@ Gopcaml_state.check_zipper_toplevel_parent ~zipper_var:Variables.zipper_var in 326 | op () 327 | ); 328 | defun 329 | ("gopcaml-zipper-space-update" |> Symbol.intern) 330 | [%here] 331 | ~docstring:{| Updates the space aroound the current item. |} 332 | (Returns (Value.Type.option (Value.Type.list Position.type_))) 333 | (let open Defun.Let_syntax in 334 | let%map_open pre_col = 335 | required "pre_col" Value.Type.int 336 | and pre_line = 337 | required "pre_line" Value.Type.int 338 | and post_col = 339 | required "post_col" Value.Type.int 340 | and post_line = 341 | required "post_line" Value.Type.int in 342 | Gopcaml_state.ensure_zipper_space ~zipper_var:Variables.zipper_var 343 | (pre_col,pre_line) (post_col, post_line) () 344 | |> Option.map ~f:(fun (a,b) -> [a;b]) 345 | ); 346 | defun 347 | ("gopcaml-zipper-move-elem-down" |> Symbol.intern) 348 | [%here] 349 | ~docstring:{| Moves the current element down and returns the bounds to transform. |} 350 | (Returns (Value.Type.option (Value.Type.list Position.type_))) 351 | (let open Defun.Let_syntax in 352 | let%map_open op = 353 | return @@ Gopcaml_state.zipper_move_down ~zipper_var:Variables.zipper_var in 354 | op () 355 | |> Option.map ~f:(fun (a,(b,c)) -> [a;b;c]) 356 | ); 357 | defun 358 | ("gopcaml-begin-zipper-swap" |> Symbol.intern) 359 | [%here] 360 | ~docstring:{| Updates the current zipper to swap the current element - returning 361 | the range to be swapped. |} 362 | (Returns (Value.Type.option (Value.Type.list Position.type_))) 363 | (let open Defun.Let_syntax in 364 | let%map_open op = 365 | return @@ Gopcaml_state.zipper_swap ~zipper_var:Variables.zipper_var in 366 | op () 367 | |> Option.map ~f:(fun ((a,b),(c,d)) -> [a; b;c;d]) 368 | ); 369 | defun 370 | ("gopcaml-begin-zipper-swap-forwards" |> Symbol.intern) 371 | [%here] 372 | ~docstring:{| Updates the current zipper to swap the current element forwards - returning 373 | the range to be swapped. |} 374 | (Returns (Value.Type.option (Value.Type.list Position.type_))) 375 | (let open Defun.Let_syntax in 376 | let%map_open op = 377 | return @@ Gopcaml_state.zipper_swap_forwards ~zipper_var:Variables.zipper_var in 378 | op () 379 | |> Option.map ~f:(fun ((a,b),(c,d)) -> [a; b;c;d]) 380 | ); 381 | defun 382 | ("gopcaml-begin-zipper-swap-backwards" |> Symbol.intern) 383 | [%here] 384 | ~docstring:{| Updates the current zipper to swap the current element forwards - returning 385 | the range to be swapped. |} 386 | (Returns (Value.Type.option (Value.Type.list Position.type_))) 387 | (let open Defun.Let_syntax in 388 | let%map_open op = 389 | return @@ Gopcaml_state.zipper_swap_backwards ~zipper_var:Variables.zipper_var in 390 | op () 391 | |> Option.map ~f:(fun ((a,b),(c,d)) -> [a; b;c;d]) 392 | ); 393 | defun 394 | ("gopcaml-begin-zipper-delete" |> Symbol.intern) 395 | [%here] 396 | ~docstring:{| Updates the current zipper to delete the current element - returning 397 | the range to be deleted. |} 398 | (Returns (Value.Type.option (Value.Type.list Position.type_))) 399 | (let open Defun.Let_syntax in 400 | let%map_open op = 401 | return @@ Gopcaml_state.zipper_delete_current ~zipper_var:Variables.zipper_var in 402 | op () 403 | |> Option.map ~f:(fun ((a,b)) -> [a; b])); 404 | defun 405 | ("gopcaml-find-defun-start" |> Symbol.intern) 406 | [%here] 407 | ~docstring:{| Returns the start of the nearest defun to POINT. |} 408 | (Returns (Value.Type.option Value.Type.int)) 409 | (let open Defun.Let_syntax in 410 | let%map_open point = required "point" Position.type_ 411 | and line = required "line" Value.Type.int 412 | and op = return @@ Gopcaml_state.find_nearest_defun ~state_var:Variables.state_var in 413 | op point line); 414 | defun 415 | ("gopcaml-find-defun-end" |> Symbol.intern) 416 | [%here] 417 | ~docstring:{| Returns the start of the nearest defun to POINT. |} 418 | (Returns (Value.Type.option Value.Type.int)) 419 | (let open Defun.Let_syntax in 420 | let%map_open point = required "point" Position.type_ 421 | and line = required "line" Value.Type.int 422 | and op = return @@ Gopcaml_state.find_nearest_defun_end ~state_var:Variables.state_var in 423 | op point line); 424 | defun 425 | ("gopcaml-find-nearest-letdef" |> Symbol.intern) 426 | [%here] 427 | ~docstring:{| Returns the start of the nearest letdef to POINT. |} 428 | (Returns (Value.Type.option Value.Type.int)) 429 | (let open Defun.Let_syntax in 430 | let%map_open point = required "point" Position.type_ 431 | and line = required "line" Value.Type.int 432 | and op = return @@ Gopcaml_state.find_nearest_letdef ~state_var:Variables.state_var in 433 | op point line); 434 | defun 435 | ("gopcaml-find-nearest-pattern" |> Symbol.intern) 436 | [%here] 437 | ~docstring:{| Returns the start of the nearest pattern to POINT. |} 438 | (Returns (Value.Type.option Value.Type.int)) 439 | (let open Defun.Let_syntax in 440 | let%map_open point = required "point" Position.type_ 441 | and line = required "line" Value.Type.int 442 | and op = return @@ Gopcaml_state.find_nearest_pattern ~state_var:Variables.state_var in 443 | op point line); 444 | defun 445 | ("gopcaml-is-inside-let-def" |> Symbol.intern) 446 | [%here] 447 | ~docstring:{| Determines whether the current item is inside a let-def. |} 448 | (Returns (Value.Type.option Value.Type.bool)) 449 | (let open Defun.Let_syntax in 450 | let%map_open point = required "point" Value.Type.int in 451 | let op = Gopcaml_state.inside_defun ~state_var:Variables.state_var in 452 | op point); 453 | defun 454 | ("gopcaml-find-free-variables" |> Symbol.intern) 455 | [%here] 456 | ~docstring:{| Returns a list of free variables in the given STRING. |} 457 | (Returns (Value.Type.list Value.Type.string)) 458 | (let open Defun.Let_syntax in 459 | let%map_open str = required "string" Value.Type.string in 460 | let vars = Gopcaml_state.find_variables_region str in 461 | vars); 462 | defun 463 | ("gopcaml-find-extract-scope" |> Symbol.intern) 464 | [%here] 465 | ~docstring:{| Returns the scope to extract a given region to. |} 466 | (Returns (Value.Type.option (Value.Type.tuple Position.type_ Position.type_))) 467 | (let open Defun.Let_syntax in 468 | let%map_open str = required "string" Value.Type.string 469 | and startp = required "beg" Position.type_ 470 | and endp = required "end" Position.type_ in 471 | let vars = Gopcaml_state.find_extract_start_scope ~state_var:Variables.state_var startp endp str in 472 | vars ()); 473 | defun 474 | ("gopcaml-find-patterns-in-scope" |> Symbol.intern) 475 | [%here] 476 | ~docstring:{| Returns the patterns around the current item. |} 477 | (Returns (Value.Type.list (Value.Type.tuple Position.type_ Position.type_))) 478 | (let open Defun.Let_syntax in 479 | let%map_open point = required "point" Position.type_ in 480 | let vars = Gopcaml_state.find_patterns_in_current 481 | ~state_var:Variables.state_var point in 482 | vars ()); 483 | defun 484 | ("gopcaml-find-valid-matches" |> Symbol.intern) 485 | [%here] 486 | ~docstring:{| Given a list of matches in the current scope, returns those that are valid. |} 487 | (Returns (Value.Type.list (Value.Type.tuple Position.type_ Position.type_))) 488 | (let open Defun.Let_syntax in 489 | let%map_open point = required "point" Position.type_ 490 | and matches = 491 | required "matches" (Value.Type.list (Value.Type.tuple Position.type_ Position.type_)) 492 | and startp = required "beg" Position.type_ 493 | and endp = required "end" Position.type_ 494 | in 495 | let vars = 496 | Gopcaml_state.find_extraction_matches 497 | ~state_var:Variables.state_var point matches (startp,endp) in 498 | vars ()) 499 | 500 | let is_excluded_file () = 501 | let (>>=) x f = Option.bind x ~f in 502 | let ignored_extensions = Customization.value Customizable.ignored_extensions_var in 503 | let result = 504 | (Current_buffer.file_name ()) >>= fun file_name -> 505 | (String.split ~on:'.' file_name |> List.last) >>= fun ext -> 506 | Some (List.mem ~equal:String.equal ignored_extensions ext) in 507 | Option.value ~default:false result 508 | 509 | let gopcaml_mode = 510 | let sym = ("gopcaml-mode" |> Symbol.intern) in 511 | Major_mode.define_derived_mode 512 | sym 513 | [%here] 514 | ~docstring:"OCaml major mode for structural syntax-aware \ 515 | editing. OCaml editing on steriods!" 516 | ~mode_line:"GopCaml" 517 | ~parent:Major_mode.Tuareg.major_mode 518 | ~initialize:((Returns Value.Type.unit), 519 | fun () -> 520 | let () = Logging.setup_logging Customizable.messaging_level_var in 521 | if not (is_excluded_file ()) then begin 522 | let _ = (Gopcaml_state.setup_gopcaml_state 523 | ~state_var:Variables.state_var 524 | ~interface_extension_var:Customizable.interface_extensions_var 525 | ~implementation_extension_var:Customizable.implementation_extensions_var 526 | ) in 527 | define_functions () 528 | end) 529 | () 530 | 531 | (* Finally, provide the gopcaml symbol *) 532 | let () = 533 | provide ("gopcaml" |> Symbol.intern) 534 | 535 | 536 | -------------------------------------------------------------------------------- /gopcaml_state.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Ecaml 3 | open Generic_types 4 | 5 | let position_sub1 pos = if Position.to_int pos <= 1 then pos else Position.sub pos 1 6 | 7 | let byte_of_position_safe pos = if Int.(pos = 0) then Position.of_int_exn pos else Position.of_byte_position pos 8 | 9 | 10 | let message ?at msg = Logging.message ?at msg 11 | 12 | module State = struct 13 | 14 | module Filetype = struct 15 | 16 | (** records whether the current file is an interface or implementation *) 17 | type s = Interface | Implementation [@@deriving sexp] 18 | 19 | module Enum : Enum.S with type t = s = struct 20 | type t = s 21 | let all = [Interface; Implementation] 22 | let sexp_of_t = sexp_of_s 23 | end 24 | 25 | let ty = 26 | let to_ecaml file_type = 27 | match file_type with 28 | | Interface -> Value.intern "interface" 29 | | Implementation -> Value.intern "implementation" in 30 | Value.Type.enum 31 | (Sexp.Atom "filetype") 32 | (module Enum) 33 | to_ecaml 34 | 35 | let to_string = function 36 | | Interface -> "interface" 37 | | Implementation -> "implementation" 38 | 39 | type t = s 40 | end 41 | 42 | module Direction = struct 43 | 44 | (** records whether moving forward or backwards *) 45 | type s = Forward | Backward [@@deriving sexp] 46 | 47 | 48 | module Enum : Enum.S with type t = s = struct 49 | type t = s 50 | let all = [Forward; Backward] 51 | let sexp_of_t = sexp_of_s 52 | end 53 | 54 | let ty = 55 | let to_ecaml direction = 56 | match direction with 57 | | Forward -> Value.intern "forward" 58 | | Backward -> Value.intern "backward" in 59 | Value.Type.enum 60 | (Sexp.Atom "direction") 61 | (module Enum) 62 | to_ecaml 63 | 64 | let to_string = function 65 | | Forward -> "forward" 66 | | Backward -> "backward" 67 | 68 | type t = s 69 | end 70 | 71 | 72 | module Zipper = struct 73 | 74 | type t = Ast_zipper.location 75 | 76 | (** elisp type for state of system *) 77 | let ty : t Value.Type.t = 78 | Caml_embed.create_type 79 | (Type_equal.Id.create 80 | ~name:"gopcaml-zipper-location" 81 | Sexplib0.Sexp_conv.sexp_of_opaque) 82 | end 83 | 84 | (** region of the buffer *) 85 | type region = { 86 | start_mark: Marker.t; 87 | end_mark: Marker.t ; 88 | (** denotes the start and end of the region *) 89 | logical_start: Line_and_column.t; 90 | logical_end: Line_and_column.t 91 | } 92 | 93 | (** holds the parse tree for the current file *) 94 | type 'a ast_tree = 95 | (** the variant simply defines the type of ast. 96 | the value is a list of the top-level items, where each item is 97 | reported as: region * ast in that region 98 | 99 | when a change occurs, we: 100 | - find region containing change, 101 | - reparse region, update element 102 | - if that fails (could be that toplevel structure changed), 103 | then parse from region start to end of file, 104 | update rest of list 105 | *) 106 | | Impl : (region * Parsetree.structure_item) list -> Parsetree.structure_item ast_tree 107 | | Intf : (region * Parsetree.signature_item) list -> Parsetree.signature_item ast_tree 108 | 109 | type parse_tree = 110 | | MkParseTree : 'a ast_tree -> parse_tree 111 | 112 | type 'a ast_item = 113 | | ImplIt : (region * Parsetree.structure_item) -> Parsetree.structure_item ast_item 114 | | IntfIt : (region * Parsetree.signature_item) -> Parsetree.signature_item ast_item 115 | 116 | type parse_item = 117 | | MkParseItem : 'a ast_item -> parse_item 118 | 119 | module TreeBuilder = struct 120 | let unwrap_current_buffer current_buffer = 121 | match current_buffer with Some v -> v | None -> Current_buffer.get () 122 | 123 | (** builds the abstract tree for the current buffer buffer *) 124 | let build_abstract_tree f g h ?current_buffer value = 125 | let current_buffer = unwrap_current_buffer current_buffer in 126 | let lexbuf = Lexing.from_string ~with_positions:true value in 127 | let items = 128 | f lexbuf 129 | |> List.map ~f:(fun item -> 130 | let (iterator,get_result) = Ast_transformer.bounds_iterator () in 131 | g iterator item; 132 | let (min_column, max_column) = get_result () in 133 | let start_marker,end_marker = Marker.create (), Marker.create () in 134 | let get_position column = byte_of_position_safe column in 135 | (* Point.goto_line_and_column Line_and_column.{line;column}; 136 | * Point.get () in *) 137 | 138 | Marker.set start_marker current_buffer (get_position min_column); 139 | Marker.set end_marker current_buffer (get_position max_column); 140 | {start_mark=start_marker; 141 | end_mark=end_marker; 142 | logical_start = Line_and_column.{line=0;column=min_column}; 143 | logical_end = Line_and_column.{line=0;column=max_column}; 144 | },item) 145 | in 146 | if not @@ String.is_empty value then 147 | try Either.First (h items) with 148 | Syntaxerr.Error e -> Either.Second e 149 | else Either.First (h []) 150 | 151 | 152 | 153 | let build_implementation_tree = 154 | build_abstract_tree 155 | Generic_parser.implementation 156 | (fun iterator item -> iterator.structure_item iterator item) 157 | (fun x -> Impl x) 158 | 159 | let build_interface_tree = 160 | build_abstract_tree 161 | Generic_parser.interface 162 | (fun iterator item -> iterator.signature_item iterator item) 163 | (fun x -> Intf x) 164 | 165 | (** determines the file-type of the current file based on its extension *) 166 | let retrieve_current_file_type ~implementation_extensions ~interface_extensions = 167 | Current_buffer.file_name () 168 | |> Option.bind ~f:(fun file_name -> 169 | String.split ~on:'.' file_name 170 | |> List.last 171 | |> Option.bind ~f:(fun ext -> 172 | if List.mem ~equal:String.(=) implementation_extensions ext 173 | then begin 174 | message ~at:`verbose "filetype is implementation"; 175 | Some Filetype.Implementation 176 | end 177 | else if List.mem ~equal:String.(=) interface_extensions ext 178 | then begin 179 | message ~at:`verbose "filetype is interface"; 180 | Some Filetype.Interface 181 | end 182 | else None 183 | ) 184 | ) 185 | 186 | 187 | (** attempts to parse the current buffer according to the inferred file type *) 188 | let parse_current_buffer ?start ?end_ file_type = 189 | (* retrieve the text for the entire buffer *) 190 | let buffer_text = 191 | Current_buffer.contents ?start ?end_ () |> Text.to_utf8_bytes |> Preprocessing.preprocess in 192 | let perform_parse () = 193 | message ~at:`info "Building parse tree - may take a while if the file is large..."; 194 | let start_time = Time_float.now () in 195 | let parse_tree = 196 | let map ~f = Either.map ~second:(fun x -> x) ~first:(fun x -> f x) in 197 | let open Filetype in 198 | match file_type with 199 | | Implementation -> map ~f:(fun x -> MkParseTree x) @@ 200 | build_implementation_tree buffer_text 201 | | Interface -> map ~f:(fun x -> MkParseTree x) @@ 202 | build_interface_tree buffer_text 203 | in 204 | match parse_tree with 205 | | Either.Second _e -> 206 | message ~at:`info ("Could not build parse tree (syntax error)"); 207 | None 208 | | Either.First tree -> 209 | let end_time = Time_float.now () in 210 | message ~at:`info (Printf.sprintf 211 | "Successfully built parse tree (%f ms)" 212 | ((Time_float.diff end_time start_time) |> Time_float.Span.to_ms) 213 | ); 214 | Some tree 215 | in 216 | if not @@ String.is_empty buffer_text then 217 | try perform_parse () 218 | with 219 | Parser.Error -> message ~at:`verbose (Printf.sprintf "parsing got error parse.error"); None 220 | | Syntaxerr.Error _ -> None 221 | else match file_type with 222 | | Interface -> Some (MkParseTree (Intf [])) 223 | | Implementation -> Some (MkParseTree (Impl [])) 224 | 225 | let calculate_region mi ma structure_list _ (* dirty_region *) = 226 | (* first split the list of structure-items by whether they are invalid or not *) 227 | let is_invalid ms2 me2 = 228 | let region_contains s1 e1 s2 e2 = 229 | let open Position in 230 | (((s1 <= s2) && (s2 <= e1)) || 231 | ((s1 <= e2) && (e2 <= e1)) || 232 | ((s2 <= s1) && (s1 <= e2)) || 233 | ((s2 <= e1) && (e1 <= e2)) 234 | ) in 235 | match Marker.position ms2, Marker.position me2 with 236 | | Some s2, Some e2 -> 237 | region_contains mi ma s2 e2 238 | | _ -> true in 239 | let (pre, invalid) = 240 | List.split_while ~f:(fun ({ start_mark; end_mark; _ }, _) -> 241 | not @@ is_invalid start_mark end_mark 242 | ) structure_list in 243 | let invalid = List.rev invalid in 244 | let (post, inb) = 245 | List.split_while ~f:(fun ({ start_mark; end_mark; _ }, _) -> 246 | not @@ is_invalid start_mark end_mark 247 | ) invalid in 248 | let post = List.rev post in 249 | (pre,inb,post) 250 | 251 | let calculate_start_end f mi ma pre_edit_region invalid_region post_edit_region = 252 | let start_region = 253 | match List.last pre_edit_region with 254 | | Some (_, st) -> 255 | let (iterator,get_bounds) = Ast_transformer.bounds_iterator () in 256 | f iterator st; 257 | let (_,c) = get_bounds () in 258 | byte_of_position_safe c 259 | | None -> 260 | match invalid_region with 261 | | (_,st) :: _ -> 262 | let (iterator,get_bounds) = Ast_transformer.bounds_iterator () in 263 | f iterator st; 264 | let (_,c) = get_bounds () in 265 | byte_of_position_safe c 266 | | [] -> mi 267 | in 268 | let end_region = 269 | match post_edit_region with 270 | | (_, st) :: _ -> 271 | let (iterator,get_bounds) = Ast_transformer.bounds_iterator () in 272 | f iterator st; 273 | let (_,c) = get_bounds () in 274 | byte_of_position_safe c 275 | | [] -> 276 | match List.last invalid_region with 277 | | Some (_,st) -> 278 | let (iterator,get_bounds) = Ast_transformer.bounds_iterator () in 279 | f iterator st; 280 | let (_,c) = get_bounds () in 281 | byte_of_position_safe c 282 | | None -> ma in 283 | (start_region,end_region) 284 | 285 | let abstract_rebuild_region f start_region end_region pre_edit_region post_edit_region = 286 | (* first, attempt to parse the exact modified region *) 287 | match parse_current_buffer ~start:start_region ~end_:end_region Filetype.Interface 288 | with 289 | | Some v -> let reparsed_range = f v in pre_edit_region @ reparsed_range @ post_edit_region 290 | | None -> 291 | (* otherwise, try to reparse from the start to the end *) 292 | match parse_current_buffer ~start:start_region Filetype.Interface with 293 | | Some v -> let reparsed_range = f v in pre_edit_region @ reparsed_range 294 | | None -> 295 | (* otherwise, try to reparse from the start to the end *) 296 | match parse_current_buffer Filetype.Interface 297 | with 298 | | Some v -> let reparsed_range = f v in reparsed_range 299 | | None -> pre_edit_region @ post_edit_region 300 | 301 | let rebuild_intf_parse_tree min max structure_list dirty_region = 302 | let mi,ma = byte_of_position_safe min, byte_of_position_safe max in 303 | let (pre_edit_region,invalid_region,post_edit_region) = 304 | calculate_region mi ma structure_list dirty_region in 305 | let (start_region,end_region) = 306 | calculate_start_end 307 | (fun iterator st -> iterator.signature_item iterator st) 308 | mi ma pre_edit_region invalid_region post_edit_region in 309 | abstract_rebuild_region 310 | (fun (MkParseTree tree) -> 311 | match tree with 312 | | Impl _ -> assert false 313 | | Intf reparsed_range -> reparsed_range) 314 | start_region end_region pre_edit_region post_edit_region 315 | 316 | let rebuild_impl_parse_tree min max structure_list dirty_region = 317 | let mi,ma = byte_of_position_safe min, byte_of_position_safe max in 318 | let (pre_edit_region,invalid_region,post_edit_region) = 319 | calculate_region mi ma structure_list dirty_region in 320 | let (start_region,end_region) = 321 | calculate_start_end 322 | (fun iterator st -> iterator.structure_item iterator st) 323 | mi ma pre_edit_region invalid_region post_edit_region in 324 | abstract_rebuild_region 325 | (fun (MkParseTree tree) -> 326 | match tree with 327 | | Impl reparsed_range -> reparsed_range 328 | | Intf _ -> assert false) 329 | start_region end_region pre_edit_region post_edit_region 330 | 331 | end 332 | 333 | 334 | module DirtyRegion = struct 335 | (** Tracks the ast - either clean, or dirty (and whether it has 336 | been changed since last compile attempt) *) 337 | type t = 338 | | Clean of parse_tree 339 | | Dirty of (parse_tree option * bool) 340 | 341 | let get_dirty_region = function 342 | | Clean _ -> None 343 | | Dirty _ -> Some (0,-1) 344 | 345 | let is_dirty = function 346 | | Clean _ -> false 347 | | _ -> true 348 | 349 | (** creates a clean dirty region from a parse tree *) 350 | let create tree = Clean tree 351 | 352 | (** updates the parse tree to denote the range of the dirty region *) 353 | let update (s:t) (_s,_e,_l: (int * int * int)) : t = 354 | (* todo: track detailed changes *) 355 | match (s : t) with 356 | | Clean tree -> Dirty (Some tree, true) 357 | | Dirty (tree,_) -> Dirty (tree, true) 358 | 359 | 360 | (** builds an updated parse_tree (updating any dirty regions) *) 361 | let to_tree (dr:t) (_file_type: Filetype.t) : parse_tree option = 362 | match dr with 363 | | Clean tree -> Some tree 364 | | Dirty _ -> 365 | TreeBuilder.parse_current_buffer _file_type 366 | 367 | (** returns the parse tree - even if it may be dirty *) 368 | let to_tree_immediate (dr:t) (_file_type: Filetype.t) : parse_tree option = 369 | match dr with 370 | | Clean tree -> Some tree 371 | | Dirty (tree, _) -> tree 372 | 373 | end 374 | 375 | (** type of state of plugin - pre-validation *) 376 | type t = { 377 | (** file type of the current buffer *) 378 | file_type: Filetype.t; 379 | (** parse tree of the current buffer + any dirty regions *) 380 | parse_tree: DirtyRegion.t; 381 | } 382 | 383 | module Validated = struct 384 | (** type of valid state of plugin *) 385 | type s = { 386 | (** file type of the current buffer *) 387 | file_type: Filetype.t; 388 | (** parse tree of the current buffer *) 389 | parse_tree: parse_tree; 390 | } 391 | 392 | (** builds a validated instance of gopcaml-state - 393 | returning a new copy of the state if it has changed*) 394 | let of_state (state: t) = 395 | let (>>=) x f = Option.bind ~f x in 396 | let should_store = ref false in 397 | (DirtyRegion.to_tree state.parse_tree state.file_type) >>= fun parse_tree -> 398 | if DirtyRegion.is_dirty state.parse_tree then should_store := true; 399 | if !should_store then 400 | Some ({file_type=state.file_type; 401 | parse_tree}, 402 | Some ({file_type=state.file_type; 403 | parse_tree = (DirtyRegion.create parse_tree)}:t)) 404 | else 405 | Some ({file_type=state.file_type; parse_tree}, None) 406 | 407 | (** attempts to retrieve the state immediately - even if it is old or outdated *) 408 | let of_state_immediate ({ file_type; parse_tree }:t) = 409 | (match parse_tree with 410 | | DirtyRegion.Clean tree -> Some tree 411 | | DirtyRegion.Dirty (tree,_) -> tree 412 | ) 413 | |> Option.map ~f:(fun tree -> ({file_type; parse_tree = tree})) 414 | 415 | (** attempts to retrieve the state immediately - even if it is old or outdated *) 416 | let try_ensure ({ file_type; parse_tree } as state :t) = 417 | (match parse_tree with 418 | | DirtyRegion.Clean _ -> None, true 419 | | DirtyRegion.Dirty (_,false) -> None, false 420 | | DirtyRegion.Dirty (tree,true) -> 421 | let parse_tree = DirtyRegion.to_tree state.parse_tree state.file_type in 422 | begin 423 | match parse_tree with 424 | | Some tree -> 425 | Some ({file_type; parse_tree = (DirtyRegion.create tree)} :t), true 426 | | None -> 427 | Some ({ file_type; parse_tree = DirtyRegion.Dirty (tree,false)}:t), false 428 | end 429 | ) 430 | 431 | type t = s 432 | 433 | end 434 | 435 | 436 | (** elisp type for state of system *) 437 | let ty : t Value.Type.t = 438 | Caml_embed.create_type 439 | (Type_equal.Id.create 440 | ~name:"gopcaml-state" 441 | Sexplib0.Sexp_conv.sexp_of_opaque) 442 | 443 | (* let default = { 444 | * file_type = Interface; 445 | * parse_tree = DirtyRegion.Dirty (None,false); 446 | * } *) 447 | 448 | end 449 | 450 | (** sets up the gopcaml-mode state - intended to be called by the startup hook of gopcaml mode*) 451 | let setup_gopcaml_state 452 | ~state_var ~interface_extension_var 453 | ~implementation_extension_var = 454 | let current_buffer = Current_buffer.get () in 455 | (* we've set these values in their definition, so it doesn't make sense for them to be non-present *) 456 | let interface_extensions = 457 | Customization.value interface_extension_var in 458 | let implementation_extensions = 459 | Customization.value implementation_extension_var in 460 | message ~at:`verbose "Building initial state"; 461 | let file_type = 462 | let inferred = 463 | State.TreeBuilder.retrieve_current_file_type 464 | ~implementation_extensions ~interface_extensions in 465 | match inferred with 466 | | Some vl -> vl 467 | | None -> 468 | message ~at:`info "Could not infer the ocaml type (interface or \ 469 | implementation) of the current file - will attempt 470 | to proceed by defaulting to implementation."; 471 | State.Filetype.Implementation 472 | in 473 | let parse_tree = State.TreeBuilder.parse_current_buffer file_type in 474 | if Option.is_none parse_tree then 475 | message ~at:`info "Could not build parse tree - please ensure that the \ 476 | buffer is syntactically correct and call \ 477 | gopcaml-initialize to enable the full POWER of syntactic \ 478 | editing."; 479 | let state = State.{ 480 | file_type = file_type; 481 | parse_tree = match parse_tree with 482 | None -> DirtyRegion.Dirty (None, false) 483 | | Some tree -> DirtyRegion.create tree; 484 | 485 | } in 486 | Buffer_local.set state_var (Some state) current_buffer 487 | 488 | (** retrieve the gopcaml state *) 489 | let get_gopcaml_file_type ?current_buffer ~state_var () = 490 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 491 | let state = Buffer_local.get_exn state_var current_buffer in 492 | let file_type_name = State.Filetype.to_string state.State.file_type in 493 | file_type_name 494 | 495 | (** update the file type of the variable *) 496 | let set_gopcaml_file_type ?current_buffer ~state_var file_type = 497 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 498 | let state = Buffer_local.get_exn state_var current_buffer in 499 | let state = State.{state with parse_tree=Dirty (None, true); file_type = file_type } in 500 | Buffer_local.set state_var (Some state) current_buffer 501 | [@@warning "-23"] 502 | 503 | (** from a list of expressions, finds the enclosing one *) 504 | let find_enclosing_expression list point = 505 | let open State in 506 | let (left,remain) = List.split_while list ~f:(fun (region,_) -> 507 | let (>>=) v f = Option.bind ~f v in 508 | let contains = 509 | (Marker.position region.start_mark) >>= fun start_position -> 510 | (Marker.position region.end_mark) >>= fun end_position -> 511 | Some (not @@ Position.between ~low:start_position ~high:end_position point) in 512 | Option.value ~default:true contains) in 513 | let remove_region = List.map ~f:(fun (_,b) -> b) in 514 | match remain with 515 | | (_,current) :: right -> Some (remove_region left,current, remove_region right) 516 | | [] -> None 517 | 518 | (** from a list of expressions, returns the nearest expression *) 519 | let find_nearest_expression list point = 520 | let open State in 521 | match find_enclosing_expression list point with 522 | | None -> 523 | (* no enclosing expression - hence, find nearest expression *) 524 | let (>>=) v f = Option.bind ~f v in 525 | let distance ((region,_) as value) = 526 | let distance = 527 | (Marker.position region.start_mark) >>= fun start_position -> 528 | (Marker.position region.end_mark) >>= fun end_position -> 529 | Some (min (abs (Position.to_int start_position - Position.to_int point)) 530 | (abs (Position.to_int end_position - Position.to_int point))) in 531 | distance, value in 532 | let regions = List.map list ~f:distance in 533 | (List.min_elt ~compare:(fun (d,_) (d',_) -> 534 | let d = match d with Some v -> v | None -> Int.max_value in 535 | let d' = match d' with Some v -> v | None -> Int.max_value in 536 | Int.compare d d') regions) >>= fun (min, _) -> 537 | let eq = Option.equal (Int.equal) in 538 | let remove_meta (_,(_,v)) = v in 539 | begin match List.split_while regions ~f:(fun (d,_) -> not @@ eq d min) with 540 | | (left, current :: right) -> 541 | Some ( 542 | List.map ~f:remove_meta left, 543 | remove_meta current, 544 | List.map ~f:remove_meta right) 545 | | _ -> None 546 | end 547 | | v -> v 548 | 549 | let list_split_last ls = 550 | let rec loop ls acc = 551 | match ls with 552 | | h :: [] -> Some (h,List.rev acc) 553 | | h :: t -> loop t (h :: acc) 554 | | [] -> None in 555 | loop ls [] 556 | 557 | let build_zipper (state: State.Validated.t) point = 558 | let find_nearest_prev_expression f list = 559 | let (>>=) v f = Option.bind ~f v in 560 | (find_nearest_expression list point) >>= fun (left,current,right) -> 561 | if (f current) = (Position.to_byte_position point) 562 | then begin 563 | match list_split_last left with 564 | | Some (last,left) -> Some (left, last, current::right) 565 | | None -> Some (left,current,right) 566 | end 567 | else Some (left,current,right) 568 | in 569 | let sif ({ psig_loc = { loc_start; _ }; _ }:Parsetree.signature_item) = loc_start.pos_cnum in 570 | let stf ({ pstr_loc = { loc_start; _ }; _ }:Parsetree.structure_item) = loc_start.pos_cnum in 571 | begin match state.parse_tree with 572 | | (State.MkParseTree (State.Impl si_list)) -> 573 | find_nearest_prev_expression stf si_list 574 | |> Option.map ~f:(fun (left,current,right) -> 575 | Ast_zipper.make_zipper_impl left current right ) 576 | | (State.MkParseTree (State.Intf si_list)) -> 577 | find_nearest_prev_expression sif si_list 578 | |> Option.map ~f:(fun (left,current,right) -> 579 | Ast_zipper.make_zipper_intf left current right 580 | ) 581 | end 582 | 583 | let find_enclosing_structure (state: State.Validated.t) point : State.parse_item option = 584 | let open State in 585 | let open Validated in 586 | let find_enclosing_expression list = 587 | List.find list ~f:(fun (region,_) -> 588 | let (>>=) v f = Option.bind ~f v in 589 | let contains = 590 | (Marker.position region.start_mark) >>= fun start_position -> 591 | (Marker.position region.end_mark) >>= fun end_position -> 592 | Some (Position.between ~low:start_position ~high:end_position point) in 593 | Option.value ~default:false contains) in 594 | match state.parse_tree with 595 | | (State.MkParseTree (State.Impl si_list)) -> 596 | find_enclosing_expression si_list |> Option.map ~f:(fun x -> State.MkParseItem (State.ImplIt x)) 597 | | (State.MkParseTree (State.Intf si_list)) -> 598 | find_enclosing_expression si_list |> Option.map ~f:(fun x -> State.MkParseItem (State.IntfIt x)) 599 | 600 | (* determines whether we are inside a letdef *) 601 | let inside_let_def state point = 602 | let contains ({ loc_start; loc_end; _ }: Location.t) = 603 | (loc_start.pos_cnum <= point) && (point <= loc_end.pos_cnum) 604 | in 605 | let rec is_let_def_struct ({pstr_desc;_}: Parsetree.structure_item) = (match pstr_desc with 606 | | Parsetree.Pstr_eval (expr, _) -> is_let_def_expr expr 607 | | Parsetree.Pstr_value (_, vbs) -> 608 | List.fold ~init:false ~f:(fun acc value -> acc || is_in_value_binding value) vbs 609 | | Parsetree.Pstr_module mb -> is_let_def_mod_expr mb.pmb_expr 610 | | Parsetree.Pstr_recmodule mods -> 611 | List.fold ~init:false ~f:(fun acc value -> acc || is_let_def_mod_expr value.pmb_expr) mods 612 | | Parsetree.Pstr_class_type cty_decl -> 613 | List.fold ~init:false ~f:(fun acc { pci_expr; _ } -> acc || is_let_def_class_type pci_expr) 614 | cty_decl 615 | | Parsetree.Pstr_class c_decls -> 616 | List.fold ~init:false ~f:(fun acc { pci_expr; _ } -> acc || is_let_def_class_expr pci_expr) 617 | c_decls 618 | | _ -> false) 619 | 620 | and is_let_def_sig ({ psig_desc; psig_loc }: Parsetree.signature_item) = 621 | if contains psig_loc then (match psig_desc with 622 | | Parsetree.Psig_module { pmd_type; _ } -> is_let_def_mod_type pmd_type 623 | | Parsetree.Psig_recmodule decls -> 624 | List.fold ~init:false ~f:(fun acc { pmd_type; _ } -> acc || is_let_def_mod_type pmd_type) 625 | decls 626 | | Parsetree.Psig_modtype { pmtd_type; _ } -> 627 | Option.map ~f:is_let_def_mod_type pmtd_type |> Option.value ~default:false 628 | | Parsetree.Psig_include { pincl_mod; _ } -> is_let_def_mod_type pincl_mod 629 | | Parsetree.Psig_class c_decls -> 630 | List.fold ~init:false ~f:(fun acc { pci_expr; _ } -> acc || is_let_def_class_type pci_expr) 631 | c_decls 632 | | Parsetree.Psig_class_type c_decls -> 633 | List.fold ~init:false ~f:(fun acc { pci_expr; _ } -> acc || is_let_def_class_type pci_expr) 634 | c_decls 635 | | _ -> false 636 | ) else false 637 | and is_in_value_binding ({ pvb_expr; pvb_loc; _ }: Parsetree.value_binding) = 638 | if contains pvb_loc then contains pvb_expr.pexp_loc else false 639 | and is_let_def_case ({ pc_guard; pc_rhs;_ }: Parsetree.case) = 640 | (Option.map ~f:is_let_def_expr pc_guard |> Option.value ~default:false) || (is_let_def_expr pc_rhs) 641 | and is_let_def_mod_type ({ pmty_desc; pmty_loc; _ }: Parsetree.module_type) = 642 | if contains pmty_loc then (match pmty_desc with 643 | | Parsetree.Pmty_functor (omt, mt) -> 644 | (match omt with 645 | | Parsetree.Unit -> false 646 | | Parsetree.Named (_, omt) -> is_let_def_mod_type omt) || 647 | is_let_def_mod_type mt 648 | | Parsetree.Pmty_with (mt, _) -> is_let_def_mod_type mt 649 | | Parsetree.Pmty_typeof mexpr -> is_let_def_mod_expr mexpr 650 | | _ -> false) else false 651 | and is_let_def_mod_expr ({ pmod_desc; pmod_loc; _ }: Parsetree.module_expr) = 652 | if contains pmod_loc then 653 | (match pmod_desc with 654 | | Parsetree.Pmod_structure st -> 655 | List.fold ~init:false ~f:(fun acc value -> acc || is_let_def_struct value) st 656 | | Parsetree.Pmod_functor (mt, mexpr) -> 657 | (match mt with 658 | | Parsetree.Unit -> false 659 | | Parsetree.Named (_, mt) -> is_let_def_mod_type mt) || 660 | is_let_def_mod_expr mexpr 661 | | Parsetree.Pmod_constraint (mexpr, mt) -> 662 | is_let_def_mod_expr mexpr || is_let_def_mod_type mt 663 | | Parsetree.Pmod_apply (mexp1, mexp2) -> 664 | is_let_def_mod_expr mexp1 || is_let_def_mod_expr mexp2 665 | | Parsetree.Pmod_unpack expr -> is_let_def_expr expr 666 | | _ -> false) 667 | else false 668 | and is_let_def_class_field_type_kind ({ pctf_desc; pctf_loc; _ }: Parsetree.class_type_field) = 669 | if contains pctf_loc then (match pctf_desc with 670 | | Parsetree.Pctf_inherit ct -> is_let_def_class_type ct 671 | | _ -> false) else false 672 | and is_let_def_class_signature ({ pcsig_fields;_ }: Parsetree.class_signature) = 673 | List.fold ~init:false pcsig_fields 674 | ~f:(fun acc value -> acc || is_let_def_class_field_type_kind value) 675 | and is_let_def_class_type ({ pcty_desc; pcty_loc; _ }: Parsetree.class_type) = 676 | if contains pcty_loc then 677 | (match pcty_desc with 678 | | Parsetree.Pcty_signature cs -> is_let_def_class_signature cs 679 | | Parsetree.Pcty_arrow (_, _, cty) -> is_let_def_class_type cty 680 | | Parsetree.Pcty_open (_, cty) -> 681 | is_let_def_class_type cty 682 | | _ -> false 683 | ) 684 | else false 685 | and is_let_def_class_expr ({ pcl_desc; pcl_loc; _ }: Parsetree.class_expr) = 686 | if contains pcl_loc then (match pcl_desc with 687 | | Parsetree.Pcl_structure cs -> is_let_def_class_structure cs 688 | | Parsetree.Pcl_fun (_, oexpr, _, clsexpr) -> 689 | (Option.map ~f:is_let_def_expr oexpr |> Option.value ~default:false) || 690 | is_let_def_class_expr clsexpr 691 | | Parsetree.Pcl_apply (clsexpr, fields) -> 692 | is_let_def_class_expr clsexpr || 693 | List.fold ~init:false ~f:(fun acc (_,value) -> acc || is_let_def_expr value) fields 694 | | Parsetree.Pcl_let (_, vbs, cexp) -> 695 | List.fold ~init:false ~f:(fun acc value -> acc || is_in_value_binding value) vbs 696 | || is_let_def_class_expr cexp 697 | | Parsetree.Pcl_constraint (cexp, ctyp) -> 698 | is_let_def_class_expr cexp || is_let_def_class_type ctyp 699 | | Parsetree.Pcl_open (_, cexp) -> is_let_def_class_expr cexp 700 | | _ -> false) else false 701 | and is_let_def_class_field_kind cfk = match cfk with 702 | | Parsetree.Cfk_virtual _ -> false 703 | | Parsetree.Cfk_concrete (_, exp) -> is_let_def_expr exp 704 | and is_let_def_class_field ({ pcf_desc; pcf_loc; _ }: Parsetree.class_field) = 705 | if contains pcf_loc then (match pcf_desc with 706 | | Parsetree.Pcf_inherit (_, cexp, _) -> is_let_def_class_expr cexp 707 | | Parsetree.Pcf_val (_, _, cfk) -> is_let_def_class_field_kind cfk 708 | | Parsetree.Pcf_method (_, _, cfk) -> is_let_def_class_field_kind cfk 709 | | Parsetree.Pcf_initializer exp -> is_let_def_expr exp 710 | | _ -> false 711 | ) else false 712 | and is_let_def_class_structure ({ pcstr_fields; _ }: Parsetree.class_structure) = 713 | List.fold ~init:false pcstr_fields ~f:(fun acc value -> acc || is_let_def_class_field value) 714 | and is_let_def_expr ({ pexp_desc; pexp_loc; _ }:Parsetree.expression) = 715 | if contains pexp_loc then 716 | (match pexp_desc with 717 | (* check if in any of the value bindings *) 718 | | Parsetree.Pexp_let (_, vbs, expr) -> 719 | List.fold ~init:false ~f:(fun acc value -> acc || is_in_value_binding value) vbs 720 | || is_let_def_expr expr 721 | | Parsetree.Pexp_function cases -> 722 | List.fold ~init:false ~f:(fun acc value -> acc || is_let_def_case value) cases 723 | | Parsetree.Pexp_apply (expr, args) -> 724 | is_let_def_expr expr 725 | || List.fold ~init:false ~f:(fun acc (_, value) -> acc || is_let_def_expr value) args 726 | | Parsetree.Pexp_try (expr, cases) 727 | | Parsetree.Pexp_match (expr, cases) -> 728 | is_let_def_expr expr || 729 | List.fold ~init:false ~f:(fun acc value -> acc || is_let_def_case value) cases 730 | | Parsetree.Pexp_fun (_, oe1, _, e2) -> 731 | (Option.map ~f:is_let_def_expr oe1 |> Option.value ~default:false) || is_let_def_expr e2 732 | | Parsetree.Pexp_open (_, expr) 733 | | Parsetree.Pexp_newtype (_, expr) 734 | | Parsetree.Pexp_lazy expr 735 | | Parsetree.Pexp_poly (expr, _) 736 | | Parsetree.Pexp_assert expr 737 | | Parsetree.Pexp_setinstvar (_, expr) 738 | | Parsetree.Pexp_send (expr, _) 739 | | Parsetree.Pexp_field (expr, _) 740 | | Parsetree.Pexp_coerce (expr, _, _) 741 | | Parsetree.Pexp_constraint (expr, _) 742 | | Parsetree.Pexp_construct (_, Some expr) 743 | | Parsetree.Pexp_variant (_, Some expr) -> is_let_def_expr expr 744 | | Parsetree.Pexp_record (fields, oe1) -> 745 | List.fold ~init:false ~f:(fun acc (_, value) -> acc || is_let_def_expr value) fields || 746 | (Option.map ~f:is_let_def_expr oe1 |> Option.value ~default:false) 747 | | Parsetree.Pexp_tuple arr 748 | | Parsetree.Pexp_array arr -> 749 | List.fold ~init:false ~f:(fun acc value -> acc || (is_let_def_expr value)) arr 750 | | Parsetree.Pexp_ifthenelse (e1, e2, oe3) -> 751 | is_let_def_expr e1 || is_let_def_expr e2 || 752 | (Option.map ~f:is_let_def_expr oe3 |> Option.value ~default:false) 753 | | Parsetree.Pexp_setfield (e1, _, e2) 754 | | Parsetree.Pexp_while (e1, e2) 755 | | Parsetree.Pexp_sequence (e1, e2) -> is_let_def_expr e1 || is_let_def_expr e2 756 | | Parsetree.Pexp_for (_, e1, e2, _, e3) -> 757 | List.fold ~init:false ~f:(fun acc value -> acc || (is_let_def_expr value)) [e1;e2;e3] 758 | | Parsetree.Pexp_override overrides -> 759 | List.fold ~init:false ~f:(fun acc (_, value) -> acc || (is_let_def_expr value)) overrides 760 | | Parsetree.Pexp_letmodule (_, mod_expr, expr) -> 761 | is_let_def_mod_expr mod_expr || is_let_def_expr expr 762 | | Parsetree.Pexp_letexception (_, expr) -> is_let_def_expr expr 763 | | Parsetree.Pexp_object cs -> is_let_def_class_structure cs 764 | | Parsetree.Pexp_pack mexp -> is_let_def_mod_expr mexp 765 | | Parsetree.Pexp_letop _ -> true 766 | | _ -> false 767 | ) 768 | else false 769 | in 770 | find_enclosing_structure state (Position.of_int_exn point) 771 | |> Option.map ~f:(fun (State.MkParseItem it) -> 772 | match it with 773 | | State.ImplIt (_, st) -> is_let_def_struct st 774 | | State.IntfIt (_, si) -> is_let_def_sig si 775 | ) 776 | 777 | let apply_iterator (item: State.parse_item) iter f = 778 | let open State in 779 | let (MkParseItem elem) = item in 780 | begin match elem with 781 | | ImplIt (_,it) -> iter.Ast_iterator.structure_item iter it 782 | | IntfIt (_, it) -> iter.Ast_iterator.signature_item iter it 783 | end; 784 | f () 785 | 786 | (** returns a tuple of points enclosing the current expression *) 787 | let find_enclosing_bounds (state: State.Validated.t) ~point = 788 | find_enclosing_structure state point 789 | |> Option.bind ~f:begin fun expr -> 790 | let (iter,getter) = Ast_transformer.enclosing_bounds_iterator (Position.to_byte_position point) () in 791 | apply_iterator expr iter getter 792 | |> Option.map ~f:(fun (a,b) -> (byte_of_position_safe (a + 1), byte_of_position_safe (b + 1))) 793 | end 794 | 795 | (** returns a tuple of points enclosing the current structure *) 796 | let find_enclosing_structure_bounds (state: State.Validated.t) ~point = 797 | find_enclosing_structure state point 798 | |> Option.bind ~f:begin fun expr -> let (State.MkParseItem expr) = expr in 799 | let region = match expr with 800 | | ImplIt (r,_) -> r 801 | | IntfIt (r,_) -> r in 802 | match Marker.position region.start_mark,Marker.position region.end_mark with 803 | | Some s, Some e -> Some (Position.add s 1, Position.add e 1) 804 | | _ -> None 805 | end 806 | 807 | (** updates the dirty region of the parse tree *) 808 | let update_dirty_region ?current_buffer ~state_var (s,e,l) = 809 | let (>>=) x f = ignore @@ Option.map ~f x in 810 | let open State in 811 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 812 | (Buffer_local.get state_var current_buffer) >>= fun state -> 813 | let parse_tree = DirtyRegion.update state.parse_tree (s,e,l) in 814 | let state = {state with parse_tree = parse_tree} in 815 | Buffer_local.set state_var (Some state) current_buffer 816 | 817 | 818 | (** retrieves the dirty region if it exists *) 819 | let get_dirty_region ?current_buffer ~state_var () = 820 | let open State in 821 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 822 | let state = Buffer_local.get_exn state_var current_buffer in 823 | DirtyRegion.get_dirty_region state.parse_tree 824 | 825 | 826 | (** retrieves the gopcaml state value, attempting to construct the 827 | parse tree if it has not already been made *) 828 | let retrieve_gopcaml_state ?current_buffer ~state_var () = 829 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 830 | let state = Buffer_local.get_exn state_var current_buffer in 831 | let (>>=) x f = Option.bind ~f x in 832 | (State.Validated.of_state state) >>= fun (v_state,state) -> 833 | if Option.is_some state then Buffer_local.set state_var state current_buffer; 834 | Some v_state 835 | 836 | (** retrieves the gopcaml state value, attempting to construct the 837 | parse tree if it has not already been made *) 838 | let check_gopcaml_state_available ?current_buffer ~state_var () = 839 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 840 | let state = Buffer_local.get_exn state_var current_buffer in 841 | let (state,ensured) = State.Validated.try_ensure state in 842 | if Option.is_some state then Buffer_local.set state_var state current_buffer; 843 | ensured 844 | 845 | (** retrieves the gopcaml state value, without attempting to construct the 846 | parse tree if it has not already been made *) 847 | let retrieve_gopcaml_state_immediate ?current_buffer ~state_var () = 848 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 849 | let state = Buffer_local.get_exn state_var current_buffer in 850 | State.Validated.of_state_immediate state 851 | 852 | (** retrieve the points enclosing structure at the current position *) 853 | let retrieve_enclosing_structure_bounds ?current_buffer ~state_var point = 854 | retrieve_gopcaml_state ?current_buffer ~state_var () 855 | |> Option.bind ~f:(find_enclosing_structure_bounds ~point) 856 | 857 | (** retrieve the points enclosing expression at the current position *) 858 | let retrieve_enclosing_bounds ?current_buffer ~state_var point = 859 | retrieve_gopcaml_state ?current_buffer ~state_var () 860 | |> Option.bind ~f:(find_enclosing_bounds ~point) 861 | 862 | 863 | let print_zipper = 864 | Option.map ~f:(fun zipper -> 865 | message ~at:`debug (Ast_zipper.describe_current_item zipper); 866 | zipper) 867 | 868 | (** retrieve a zipper expression at the current position *) 869 | let build_zipper_enclosing_point ?direction ?current_buffer ~state_var ~zipper_var point line = 870 | let direction = match direction with 871 | | None -> false 872 | | Some v -> v in 873 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 874 | retrieve_gopcaml_state ~current_buffer ~state_var () 875 | |> Option.bind ~f:(fun state -> 876 | let zipper = build_zipper state point 877 | |> Option.map ~f:(Ast_zipper.move_zipper_to_point 878 | (Position.to_byte_position @@ position_sub1 point) 879 | line direction) in 880 | Buffer_local.set zipper_var zipper current_buffer; 881 | zipper) 882 | |> print_zipper 883 | |> Option.map ~f:Ast_zipper.to_bounds 884 | |> Option.map ~f:(fun (st,ed) -> 885 | byte_of_position_safe (st + 1), byte_of_position_safe (ed + 1) 886 | ) 887 | 888 | (** retrieve a zipper enclosing structure at the current position *) 889 | let build_zipper_broadly_enclosing_point ?current_buffer ~state_var ~zipper_var point line = 890 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 891 | retrieve_gopcaml_state ~current_buffer ~state_var () 892 | |> Option.bind ~f:(fun state -> 893 | let zipper = build_zipper state point 894 | |> Option.map ~f:(Ast_zipper.move_zipper_broadly_to_point 895 | (Position.to_byte_position @@ position_sub1 point) 896 | line false) in 897 | Buffer_local.set zipper_var zipper current_buffer; 898 | zipper) 899 | |> print_zipper 900 | |> Option.map ~f:Ast_zipper.to_bounds 901 | |> Option.map ~f:(fun (st,ed) -> 902 | byte_of_position_safe (st + 1), byte_of_position_safe (ed + 1) 903 | ) 904 | 905 | (** returns the point corresponding to the start of the nearest defun (or respective thing in ocaml) *) 906 | let find_nearest_defun ?current_buffer ~state_var point line = 907 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 908 | retrieve_gopcaml_state ~current_buffer ~state_var () 909 | |> Option.bind ~f:(fun state -> build_zipper state (position_sub1 point) ) 910 | |> Option.bind ~f:(fun zipper -> Ast_zipper.find_nearest_definition_item_bounds 911 | (Position.to_byte_position @@ position_sub1 point) 912 | (line + 1) 913 | false 914 | zipper) 915 | |> Option.map ~f:(fun x -> x + 1) 916 | 917 | (** returns the point corresponding to the start of the nearest defun (or respective thing in ocaml) *) 918 | let find_nearest_defun_end ?current_buffer ~state_var point line = 919 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 920 | retrieve_gopcaml_state ~current_buffer ~state_var () 921 | |> Option.bind ~f:(fun state -> 922 | build_zipper state (position_sub1 point) 923 | ) 924 | |> Option.bind ~f:(fun zipper -> 925 | let start = (Position.to_byte_position @@ position_sub1 point) in 926 | Ast_zipper.find_nearest_definition_item_bounds 927 | start 928 | line 929 | true 930 | zipper) 931 | |> Option.map ~f:(fun x -> x + 1) 932 | 933 | 934 | (** returns the point corresponding to the start of the nearest letdef (or respective thing in ocaml) *) 935 | let find_nearest_letdef ?current_buffer ~state_var point line = 936 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 937 | retrieve_gopcaml_state ~current_buffer ~state_var () 938 | |> Option.bind ~f:(fun state -> build_zipper state (position_sub1 point)) 939 | |> Option.map ~f:(Ast_zipper.move_zipper_to_point 940 | (Position.to_byte_position Position.(sub point 1)) line false ) 941 | |> Option.bind ~f:(fun zipper -> Ast_zipper.find_nearest_letdef 942 | (Position.to_byte_position Position.(sub point 1)) 943 | zipper) 944 | |> Option.map ~f:(fun x -> x + 1) 945 | 946 | (** returns the point corresponding to the start of the nearest pattern (or respective thing in ocaml) *) 947 | let find_nearest_pattern ?current_buffer ~state_var point line = 948 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 949 | retrieve_gopcaml_state ~current_buffer ~state_var () 950 | |> Option.bind ~f:(fun state -> build_zipper state (position_sub1 point)) 951 | |> Option.map ~f:( Ast_zipper.move_zipper_to_point 952 | (Position.to_byte_position Position.(sub point 1)) line false ) 953 | |> Option.bind ~f:(fun zipper -> Ast_zipper.find_nearest_pattern 954 | (Position.to_byte_position Position.(sub point 1)) 955 | zipper) 956 | |> Option.map ~f:(fun x -> x + 1) 957 | 958 | 959 | (** returns whether the point is inside a let def (and thus when 960 | expanding let we should include an in) *) 961 | let inside_defun ?current_buffer ~state_var point = 962 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 963 | retrieve_gopcaml_state_immediate ~current_buffer ~state_var () 964 | |> Option.bind ~f:(fun state -> inside_let_def state point) 965 | 966 | 967 | (** retrieve zipper *) 968 | let retrieve_zipper ?current_buffer ~zipper_var = 969 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 970 | Buffer_local.get zipper_var current_buffer 971 | 972 | (** delete zipper *) 973 | let delete_zipper ?current_buffer ~zipper_var () = 974 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 975 | Buffer_local.set zipper_var None current_buffer 976 | 977 | (** delete state *) 978 | let delete_state ?current_buffer ~state_var () = 979 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 980 | Buffer_local.set state_var None current_buffer 981 | 982 | 983 | 984 | let abstract_zipper_to_bounds zipper = zipper 985 | |> Option.map ~f:Ast_zipper.to_bounds 986 | |> Option.map ~f:(fun (st,ed) -> 987 | byte_of_position_safe (st + 1), byte_of_position_safe (ed + 1) 988 | ) 989 | 990 | (** retrieve bounds for current zipper *) 991 | let retrieve_zipper_bounds ?current_buffer ~zipper_var () = 992 | retrieve_zipper ?current_buffer ~zipper_var 993 | |> abstract_zipper_to_bounds 994 | 995 | (** checks whether the current zipper item is a top-level item *) 996 | let check_zipper_toplevel ?current_buffer ~zipper_var () = 997 | retrieve_zipper ?current_buffer ~zipper_var 998 | |> Option.map ~f:(Ast_zipper.zipper_is_top_level) 999 | 1000 | let check_zipper_toplevel_parent ?current_buffer ~zipper_var () = 1001 | retrieve_zipper ?current_buffer ~zipper_var 1002 | |> Option.map ~f:(Ast_zipper.zipper_is_top_level_parent) 1003 | 1004 | (** attempts to move the current zipper left *) 1005 | let move_zipper_left ?current_buffer ~zipper_var () = 1006 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 1007 | retrieve_zipper ~current_buffer ~zipper_var 1008 | |> Option.bind ~f:Ast_zipper.go_left 1009 | |> Option.map ~f:(fun zipper -> 1010 | Buffer_local.set zipper_var (Some zipper) current_buffer; 1011 | zipper 1012 | ) 1013 | |> abstract_zipper_to_bounds 1014 | 1015 | (** attempts to move the current zipper left *) 1016 | let ensure_zipper_space ?current_buffer ~zipper_var (pre_column,pre_line) (post_column,post_line) () = 1017 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 1018 | retrieve_zipper ~current_buffer ~zipper_var 1019 | |> Option.bind ~f:(fun zipper -> Ast_zipper.update_zipper_space_bounds zipper 1020 | (pre_column,pre_line) (post_column,post_line)) 1021 | |> Option.map ~f:(fun zipper -> 1022 | Buffer_local.set zipper_var (Some zipper) current_buffer; 1023 | zipper 1024 | ) 1025 | |> abstract_zipper_to_bounds 1026 | 1027 | (** attempts to move the current zipper right *) 1028 | let move_zipper_right ?current_buffer ~zipper_var () = 1029 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 1030 | retrieve_zipper ~current_buffer ~zipper_var 1031 | |> Option.bind ~f:Ast_zipper.go_right 1032 | |> Option.map ~f:(fun zipper -> 1033 | Buffer_local.set zipper_var (Some zipper) current_buffer; 1034 | zipper 1035 | ) 1036 | |> abstract_zipper_to_bounds 1037 | 1038 | (** attempts to move the current zipper down *) 1039 | let move_zipper_down ?current_buffer ~zipper_var () = 1040 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 1041 | retrieve_zipper ~current_buffer ~zipper_var 1042 | |> Option.bind ~f:Ast_zipper.go_down 1043 | |> Option.map ~f:(fun zipper -> 1044 | Buffer_local.set zipper_var (Some zipper) current_buffer; 1045 | zipper 1046 | ) 1047 | |> abstract_zipper_to_bounds 1048 | 1049 | (** attempts to move the current zipper up *) 1050 | let move_zipper_up ?current_buffer ~zipper_var () = 1051 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 1052 | retrieve_zipper ~current_buffer ~zipper_var 1053 | |> Option.bind ~f:Ast_zipper.go_up 1054 | |> Option.map ~f:(fun zipper -> 1055 | Buffer_local.set zipper_var (Some zipper) current_buffer; 1056 | zipper 1057 | ) 1058 | |> abstract_zipper_to_bounds 1059 | 1060 | (** attempts "update" the buffer using the zipper, returning the two regions to be swapped *) 1061 | let abstract_zipper_update f ?current_buffer ~zipper_var () = 1062 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 1063 | retrieve_zipper ~current_buffer ~zipper_var 1064 | |> Option.bind ~f 1065 | |> Option.map ~f:(fun (r1,r2,zipper) -> 1066 | let r1 = Text_region.to_bounds r1 in 1067 | let r2 = Text_region.to_bounds r2 in 1068 | (r1,r2,zipper) 1069 | ) 1070 | |> Option.map ~f:(fun ((l1,l2),(r1,r2),zipper) -> 1071 | Buffer_local.set zipper_var (Some zipper) current_buffer; 1072 | (byte_of_position_safe (l1 + 1),byte_of_position_safe (l2 + 1)), 1073 | (byte_of_position_safe (r1 + 1),byte_of_position_safe (r2 + 1)) 1074 | ) 1075 | 1076 | (** attempts to swap the zipper *) 1077 | let zipper_swap = abstract_zipper_update Ast_zipper.calculate_swap_bounds 1078 | 1079 | (** attempts to move the current expression forwards *) 1080 | let zipper_swap_forwards = abstract_zipper_update Ast_zipper.calculate_swap_forward_bounds 1081 | 1082 | (** attempts to move the current expression backwards *) 1083 | let zipper_swap_backwards = abstract_zipper_update Ast_zipper.calculate_swap_backwards_bounds 1084 | 1085 | (** deletes the current item using the zipper, returning the region to be swapped *) 1086 | let zipper_delete_current ?current_buffer ~zipper_var () = 1087 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 1088 | retrieve_zipper ~current_buffer ~zipper_var 1089 | |> Option.bind ~f:Ast_zipper.calculate_zipper_delete_bounds 1090 | |> Option.map ~f:(fun (zipper, r1) -> 1091 | let r1 = Text_region.to_bounds r1 in 1092 | (zipper,r1) 1093 | ) 1094 | |> Option.map ~f:(fun (zipper,(l1,l2)) -> 1095 | Buffer_local.set zipper_var (Some zipper) current_buffer; 1096 | (byte_of_position_safe (l1 + 1),byte_of_position_safe (l2 + 1)) 1097 | ) 1098 | 1099 | let zipper_move_up ?current_buffer ~zipper_var () = 1100 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 1101 | retrieve_zipper ~current_buffer ~zipper_var 1102 | |> Option.bind ~f:(Ast_zipper.move_up) 1103 | |> Option.map ~f:(fun (zipper,pos,(ds,de)) -> 1104 | Buffer_local.set zipper_var (Some zipper) current_buffer; 1105 | (byte_of_position_safe (pos + 1), 1106 | (byte_of_position_safe (ds + 1), 1107 | byte_of_position_safe (de + 1) 1108 | )) 1109 | ) 1110 | 1111 | let zipper_move_down ?current_buffer ~zipper_var () = 1112 | let current_buffer = match current_buffer with Some v -> v | None -> Current_buffer.get () in 1113 | retrieve_zipper ~current_buffer ~zipper_var 1114 | |> Option.bind ~f:(Ast_zipper.move_down) 1115 | |> Option.map ~f:(fun (zipper,pos,(ds,de)) -> 1116 | Buffer_local.set zipper_var (Some zipper) current_buffer; 1117 | (byte_of_position_safe (pos + 1), 1118 | (byte_of_position_safe (ds + 1), 1119 | byte_of_position_safe (de + 1) 1120 | )) 1121 | ) 1122 | 1123 | (** finds all variables in the given expression *) 1124 | let find_variables_region text = 1125 | try 1126 | let exp = 1127 | let lexbuf = Lexing.from_string ~with_positions:true text in 1128 | Generic_parser.expression lexbuf 1129 | in 1130 | Ast_analysis.find_variables_exp exp 1131 | with 1132 | Parser.Error -> message ~at:`verbose (Printf.sprintf "parsing got error parse.error"); [] 1133 | | Syntaxerr.Error _ -> [] 1134 | 1135 | 1136 | 1137 | (** find the closest scope containing all variables used by the current expression *) 1138 | let find_extract_start_scope ?current_buffer ~state_var st_p ed_p text () = 1139 | retrieve_gopcaml_state_immediate ?current_buffer ~state_var () 1140 | |> Option.bind ~f:(fun v -> find_enclosing_structure v st_p) 1141 | |> Option.bind ~f:(fun ((State.MkParseItem it: State.parse_item)) -> 1142 | let variables = find_variables_region text in 1143 | match it with 1144 | | State.ImplIt (_,si) -> 1145 | let scopes = snd (Ast_analysis.find_scopes_si si) in 1146 | let st_p,ed_p = Position.to_byte_position Position.(sub st_p 1), 1147 | Position.to_byte_position Position.(sub ed_p 1) in 1148 | let selected_scope = 1149 | Ast_analysis.find_lub_scope variables scopes (st_p,ed_p) 1150 | in 1151 | let selected_scope = 1152 | match selected_scope with 1153 | | None -> 1154 | Ast_analysis.find_smallest_enclosing_scope scopes (st_p, ed_p) 1155 | | v -> v 1156 | in 1157 | selected_scope 1158 | | State.IntfIt (_, _) -> None 1159 | ) 1160 | |> Option.map ~f:(fun (s,e) -> (byte_of_position_safe (s + 1), byte_of_position_safe (e + 1))) 1161 | 1162 | (** find patterns in enclosing item *) 1163 | let find_patterns_in_current_internal ?current_buffer ~state_var point = 1164 | retrieve_gopcaml_state_immediate ?current_buffer ~state_var () 1165 | |> Option.bind ~f:(fun v -> find_enclosing_structure v point) 1166 | |> Option.map ~f:(fun (State.MkParseItem it: State.parse_item) -> 1167 | match it with 1168 | | State.ImplIt (_,si) -> 1169 | let scopes = (Ast_analysis.find_pattern_scopes_si si) in 1170 | scopes 1171 | | State.IntfIt (_, _) -> [] 1172 | ) 1173 | 1174 | (** find patterns in enclosing item *) 1175 | let find_excluded_scopes_in_current_internal ?current_buffer ~state_var point (startp,endp) = 1176 | retrieve_gopcaml_state_immediate ?current_buffer ~state_var () 1177 | |> Option.bind ~f:(fun v -> find_enclosing_structure v point) 1178 | |> Option.map ~f:(fun (State.MkParseItem it: State.parse_item) -> 1179 | match it with 1180 | | State.ImplIt (_,si) -> 1181 | let scopes = snd (Ast_analysis.find_scopes_si si) in 1182 | let pat_scopes = (Ast_analysis.find_pattern_scopes_si si) in 1183 | Ast_analysis.find_excluded_scopes scopes (startp,endp) @ pat_scopes 1184 | | State.IntfIt (_, _) -> [] 1185 | ) 1186 | 1187 | (** find patterns in enclosing item *) 1188 | let find_patterns_in_current ?current_buffer ~state_var point () = 1189 | find_patterns_in_current_internal ?current_buffer ~state_var point 1190 | |> Option.map ~f:(List.map ~f:(fun (st_p,ed_p) -> 1191 | let st_p,ed_p = byte_of_position_safe (st_p + 1), byte_of_position_safe (ed_p + 1) in 1192 | st_p,ed_p 1193 | )) 1194 | |> Option.value ~default:[] 1195 | 1196 | 1197 | (** given a list of matching regions for the current scope, returns those that correspond 1198 | to valid matches *) 1199 | let find_extraction_matches ?current_buffer ~state_var point matches (start_p,end_p) () = 1200 | let (start_p,end_p) = Position.to_byte_position Position.(sub start_p 1), 1201 | Position.to_byte_position Position.(sub end_p 1) in 1202 | let matches = List.map 1203 | ~f:(fun (a,b) -> Position.to_byte_position Position.(sub a 1), 1204 | Position.to_byte_position Position.(sub b 1)) 1205 | matches in 1206 | find_excluded_scopes_in_current_internal ?current_buffer ~state_var point (start_p,end_p) 1207 | |> Option.map ~f:(Ast_analysis.find_valid_matches matches) 1208 | |> Option.map ~f:(List.map ~f:(fun (st_p,ed_p) -> 1209 | let st_p,ed_p = byte_of_position_safe (st_p + 1), byte_of_position_safe (ed_p + 1) in 1210 | st_p,ed_p 1211 | )) 1212 | |> Option.value ~default:[] 1213 | 1214 | -------------------------------------------------------------------------------- /images/gopcaml_auto_let_binding_example.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kiranandcode/gopcaml-mode/9e3327786d2c8b6454e4218a153339a348cea781/images/gopcaml_auto_let_binding_example.gif -------------------------------------------------------------------------------- /images/gopcaml_extraction_expressions.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kiranandcode/gopcaml-mode/9e3327786d2c8b6454e4218a153339a348cea781/images/gopcaml_extraction_expressions.gif -------------------------------------------------------------------------------- /images/gopcaml_mark_sexp.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kiranandcode/gopcaml-mode/9e3327786d2c8b6454e4218a153339a348cea781/images/gopcaml_mark_sexp.gif -------------------------------------------------------------------------------- /images/gopcaml_move_expression_example.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kiranandcode/gopcaml-mode/9e3327786d2c8b6454e4218a153339a348cea781/images/gopcaml_move_expression_example.gif -------------------------------------------------------------------------------- /images/gopcaml_move_function_example.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kiranandcode/gopcaml-mode/9e3327786d2c8b6454e4218a153339a348cea781/images/gopcaml_move_function_example.gif -------------------------------------------------------------------------------- /images/gopcaml_move_to_defun_example.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kiranandcode/gopcaml-mode/9e3327786d2c8b6454e4218a153339a348cea781/images/gopcaml_move_to_defun_example.gif -------------------------------------------------------------------------------- /images/gopcaml_move_to_nearest_letdef.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kiranandcode/gopcaml-mode/9e3327786d2c8b6454e4218a153339a348cea781/images/gopcaml_move_to_nearest_letdef.gif -------------------------------------------------------------------------------- /images/gopcaml_move_to_parameter.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kiranandcode/gopcaml-mode/9e3327786d2c8b6454e4218a153339a348cea781/images/gopcaml_move_to_parameter.gif -------------------------------------------------------------------------------- /images/gopcaml_move_to_type_hole.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/kiranandcode/gopcaml-mode/9e3327786d2c8b6454e4218a153339a348cea781/images/gopcaml_move_to_type_hole.gif -------------------------------------------------------------------------------- /logging.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Ecaml 3 | 4 | module Level = struct 5 | type t = [`debug | `verbose | `info | `none ] [@@deriving show, ord, enum, sexp, eq] 6 | 7 | module Enum : Ecaml.Value.Type.Enum with type t = t = struct 8 | type nonrec t = t 9 | let all = [`debug ; `verbose ; `info ; `none ] 10 | let sexp_of_t = sexp_of_t 11 | end 12 | 13 | let to_ecaml file_type = 14 | match file_type with 15 | | `debug -> Value.intern "debug" 16 | | `verbose -> Value.intern "verbose" 17 | | `info -> Value.intern "info" 18 | | `none -> Value.intern "none" 19 | 20 | let ty = 21 | Value.Type.enum 22 | (Sexp.Atom "message-level") 23 | (module Enum) 24 | to_ecaml 25 | 26 | let custom_ty = Ecaml.Customization.Type.enum Enum.all to_ecaml 27 | 28 | end 29 | 30 | let log_level_var = ref @@ fun () -> assert false 31 | 32 | let setup_logging var = log_level_var := fun () -> var 33 | 34 | let log_level () = (Customization.value @@ !log_level_var ()) 35 | 36 | let message ?at:(level=`info) msg = 37 | (* TODO: This is somewhat inefficient, as it means that each message 38 | call requires interaction between OCaml and Emacs - is there a 39 | way to do this smarter? *) 40 | let log_level = log_level () in 41 | if Level.equal log_level `none || (Level.compare level log_level < 0) 42 | then () 43 | else Ecaml.message msg 44 | 45 | -------------------------------------------------------------------------------- /logging.mli: -------------------------------------------------------------------------------- 1 | open Ecaml 2 | open Core 3 | 4 | module Level : sig 5 | (** Type encoding the logging levels supported by the plugin *) 6 | type t = [ `debug | `verbose | `info | `none ] 7 | 8 | val show : t -> Ppx_deriving_runtime.string 9 | 10 | val ty : t Ecaml.Value.Type.t 11 | 12 | val custom_ty: Ecaml.Customization.Type.t 13 | 14 | end 15 | 16 | (** Setup the variable used to determine logging level *) 17 | val setup_logging: Level.t Ecaml.Customization.t -> unit 18 | 19 | (** [message ~log_level ?at msg] logs a message to the user if they have requested 20 | receiving messages at that log level. 21 | 22 | The logging level to log [at] defaults to `info. *) 23 | val message : ?at:Level.t -> string -> unit 24 | -------------------------------------------------------------------------------- /parser/408/generic_parser.ml: -------------------------------------------------------------------------------- 1 | 2 | let interface buf = 3 | (Parse.interface buf) 4 | |> Migrate_parsetree.Migrate_408_409.copy_signature 5 | |> Migrate_parsetree.Migrate_409_410.copy_signature 6 | |> Migrate_parsetree.Migrate_410_411.copy_signature 7 | |> Migrate_parsetree.Migrate_411_412.copy_signature 8 | |> Migrate_parsetree.Migrate_412_413.copy_signature 9 | |> Migrate_parsetree.Migrate_413_414.copy_signature 10 | 11 | let implementation buf = (Parse.implementation buf) 12 | |> Migrate_parsetree.Migrate_408_409.copy_structure 13 | |> Migrate_parsetree.Migrate_409_410.copy_structure 14 | |> Migrate_parsetree.Migrate_410_411.copy_structure 15 | |> Migrate_parsetree.Migrate_411_412.copy_structure 16 | |> Migrate_parsetree.Migrate_412_413.copy_structure 17 | |> Migrate_parsetree.Migrate_413_414.copy_structure 18 | 19 | let expression buf = 20 | (Parse.expression buf) 21 | |> Migrate_parsetree.Migrate_408_409.copy_expression 22 | |> Migrate_parsetree.Migrate_409_410.copy_expression 23 | |> Migrate_parsetree.Migrate_410_411.copy_expression 24 | |> Migrate_parsetree.Migrate_411_412.copy_expression 25 | |> Migrate_parsetree.Migrate_412_413.copy_expression 26 | |> Migrate_parsetree.Migrate_413_414.copy_expression 27 | 28 | -------------------------------------------------------------------------------- /parser/409/generic_parser.ml: -------------------------------------------------------------------------------- 1 | 2 | let interface buf = 3 | (Parse.interface buf) 4 | |> Migrate_parsetree.Migrate_409_410.copy_signature 5 | |> Migrate_parsetree.Migrate_410_411.copy_signature 6 | |> Migrate_parsetree.Migrate_411_412.copy_signature 7 | |> Migrate_parsetree.Migrate_412_413.copy_signature 8 | |> Migrate_parsetree.Migrate_413_414.copy_signature 9 | 10 | let implementation buf = (Parse.implementation buf) 11 | |> Migrate_parsetree.Migrate_409_410.copy_structure 12 | |> Migrate_parsetree.Migrate_410_411.copy_structure 13 | |> Migrate_parsetree.Migrate_411_412.copy_structure 14 | |> Migrate_parsetree.Migrate_412_413.copy_structure 15 | |> Migrate_parsetree.Migrate_413_414.copy_structure 16 | 17 | let expression buf = 18 | (Parse.expression buf) 19 | |> Migrate_parsetree.Migrate_409_410.copy_expression 20 | |> Migrate_parsetree.Migrate_410_411.copy_expression 21 | |> Migrate_parsetree.Migrate_411_412.copy_expression 22 | |> Migrate_parsetree.Migrate_412_413.copy_expression 23 | |> Migrate_parsetree.Migrate_413_414.copy_expression 24 | -------------------------------------------------------------------------------- /parser/410/generic_parser.ml: -------------------------------------------------------------------------------- 1 | 2 | let interface buf = 3 | (Parse.interface buf) 4 | |> Migrate_parsetree.Migrate_410_411.copy_signature 5 | |> Migrate_parsetree.Migrate_411_412.copy_signature 6 | |> Migrate_parsetree.Migrate_412_413.copy_signature 7 | |> Migrate_parsetree.Migrate_413_414.copy_signature 8 | 9 | let implementation buf = (Parse.implementation buf) 10 | |> Migrate_parsetree.Migrate_410_411.copy_structure 11 | |> Migrate_parsetree.Migrate_411_412.copy_structure 12 | |> Migrate_parsetree.Migrate_412_413.copy_structure 13 | |> Migrate_parsetree.Migrate_413_414.copy_structure 14 | 15 | let expression buf = 16 | (Parse.expression buf) 17 | |> Migrate_parsetree.Migrate_410_411.copy_expression 18 | |> Migrate_parsetree.Migrate_411_412.copy_expression 19 | |> Migrate_parsetree.Migrate_412_413.copy_expression 20 | |> Migrate_parsetree.Migrate_413_414.copy_expression 21 | 22 | -------------------------------------------------------------------------------- /parser/411/generic_parser.ml: -------------------------------------------------------------------------------- 1 | 2 | let interface buf = 3 | (Parse.interface buf) 4 | |> Migrate_parsetree.Migrate_411_412.copy_signature 5 | |> Migrate_parsetree.Migrate_412_413.copy_signature 6 | |> Migrate_parsetree.Migrate_413_414.copy_signature 7 | 8 | let implementation buf = 9 | (Parse.implementation buf) 10 | |> Migrate_parsetree.Migrate_411_412.copy_structure 11 | |> Migrate_parsetree.Migrate_412_413.copy_structure 12 | |> Migrate_parsetree.Migrate_413_414.copy_structure 13 | 14 | let expression buf = 15 | (Parse.expression buf) 16 | |> Migrate_parsetree.Migrate_411_412.copy_expression 17 | |> Migrate_parsetree.Migrate_412_413.copy_expression 18 | |> Migrate_parsetree.Migrate_413_414.copy_expression 19 | 20 | -------------------------------------------------------------------------------- /parser/412/generic_parser.ml: -------------------------------------------------------------------------------- 1 | 2 | let interface buf = 3 | (Parse.interface buf) 4 | |> Migrate_parsetree.Migrate_412_413.copy_signature 5 | |> Migrate_parsetree.Migrate_413_414.copy_signature 6 | 7 | let implementation buf = 8 | (Parse.implementation buf) 9 | |> Migrate_parsetree.Migrate_412_413.copy_structure 10 | |> Migrate_parsetree.Migrate_413_414.copy_structure 11 | 12 | let expression buf = 13 | (Parse.expression buf) 14 | |> Migrate_parsetree.Migrate_412_413.copy_expression 15 | |> Migrate_parsetree.Migrate_413_414.copy_expression 16 | -------------------------------------------------------------------------------- /parser/413/generic_parser.ml: -------------------------------------------------------------------------------- 1 | 2 | let interface buf = 3 | (Parse.interface buf) 4 | |> Migrate_parsetree.Migrate_413_414.copy_signature 5 | 6 | let implementation buf = 7 | (Parse.implementation buf) 8 | |> Migrate_parsetree.Migrate_413_414.copy_structure 9 | 10 | let expression buf = 11 | (Parse.expression buf) 12 | |> Migrate_parsetree.Migrate_413_414.copy_expression 13 | -------------------------------------------------------------------------------- /parser/414/generic_parser.ml: -------------------------------------------------------------------------------- 1 | 2 | let interface = Parse.interface 3 | let implementation = Parse.implementation 4 | let expression = Parse.expression 5 | -------------------------------------------------------------------------------- /parser/dune: -------------------------------------------------------------------------------- 1 | (* -*- tuareg -*- *) 2 | 3 | module J = Jbuild_plugin.V1 4 | ;; 5 | 6 | let ver = 7 | Scanf.sscanf J.ocaml_version "%s@.%s@." (fun maj min -> maj ^ min) 8 | ;; 9 | 10 | Printf.ksprintf J.send {| 11 | (copy_files# %s/*.ml{,i}) 12 | 13 | 14 | (library 15 | (name generic_parser) 16 | (wrapped false) 17 | (flags (:standard -w -9)) 18 | (libraries compiler-libs.common ocaml-migrate-parsetree)) 19 | |} ver 20 | -------------------------------------------------------------------------------- /parser/generic_parser.mli: -------------------------------------------------------------------------------- 1 | val interface : Lexing.lexbuf -> Migrate_parsetree.Ast_414.Parsetree.signature 2 | val implementation : Lexing.lexbuf -> Migrate_parsetree.Ast_414.Parsetree.structure 3 | val expression : Lexing.lexbuf -> Migrate_parsetree.Ast_414.Parsetree.expression 4 | -------------------------------------------------------------------------------- /preprocessing.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | 3 | let remove_shebangs txt = 4 | Option.some_if (String.is_prefix ~prefix:"#" txt) txt 5 | |> Option.bind ~f:(fun txt -> String.index txt '\n') 6 | |> Option.bind ~f:(fun ind -> 7 | Some (String.make ind ' ' ^ String.drop_prefix txt ind) 8 | ) 9 | |> Option.value ~default:txt 10 | 11 | let preprocessors = [remove_shebangs] 12 | 13 | (** Preprocesses buffer text before attempting to parse with the OCaml compiler *) 14 | let preprocess txt = 15 | let start_length = String.length txt in 16 | let txt = 17 | List.fold_left 18 | ~init:txt 19 | ~f:(fun txt pre -> pre txt) preprocessors in 20 | let end_length = String.length txt in 21 | assert (start_length = end_length); 22 | txt 23 | -------------------------------------------------------------------------------- /readme.md: -------------------------------------------------------------------------------- 1 | # NOTE: THIS IS A MIRROR 2 | Please submit issues, feature requests and PRs to https://gitlab.com/gopiandcode/gopcaml-mode 3 | 4 | # Gopcaml Ocaml Emacs Major Mode 5 | 6 | The ultimate ocaml editing mode. 7 | 8 | ## Features 9 | - AST-based code navigation - `C-M-n, C-M-p, C-M-u, C-M-d, C-M-f, C-M-b` 10 | 11 | ![ast-code-navigation](https://gitlab.com/gopiandcode/gopcaml-mode/-/raw/master/images/gopcaml_move_expression_example.gif?inline=false) 12 | 13 | - AST-based code transformation -`C-M-N, C-M-P, C-M-F, C-M-B` 14 | 15 | ![ast-code-transform](https://gitlab.com/gopiandcode/gopcaml-mode/-/raw/master/images/gopcaml_move_function_example.gif?inline=false) 16 | 17 | - Fixed move-to-defun, move-to-end-defun -`C-M-a, C-M-e` 18 | 19 | ![move-to-defun](https://gitlab.com/gopiandcode/gopcaml-mode/-/raw/master/images/gopcaml_move_to_defun_example.gif?inline=false) 20 | 21 | - Jump to type hole - `TAB` 22 | 23 | ![jump-to-type-hole](https://gitlab.com/gopiandcode/gopcaml-mode/-/raw/master/images/gopcaml_move_to_type_hole.gif?inline=false) 24 | 25 | - Automatic let binding expansion (i.e adds in automatically if defining let inside a let) 26 | 27 | ![automatic-let-bindings](https://gitlab.com/gopiandcode/gopcaml-mode/-/raw/master/images/gopcaml_auto_let_binding_example.gif?inline=false) 28 | 29 | - Mark exp - `C-M-SPC` 30 | 31 | ![mark-sexp](https://gitlab.com/gopiandcode/gopcaml-mode/-/raw/master/images/gopcaml_mark_sexp.gif?inline=false) 32 | 33 | - Move to nearest parameter - `C-c C-p` 34 | 35 | ![move-to-param](https://gitlab.com/gopiandcode/gopcaml-mode/-/raw/master/images/gopcaml_move_to_parameter.gif?inline=false) 36 | 37 | - Move to nearest let def - `C-c C-o` 38 | 39 | ![move-to-let-def](https://gitlab.com/gopiandcode/gopcaml-mode/-/raw/master/images/gopcaml_move_to_nearest_letdef.gif?inline=false) 40 | 41 | - Extract expression into letdef - `C-c C-e` 42 | 43 | ![extract-expression](https://gitlab.com/gopiandcode/gopcaml-mode/-/raw/master/images/gopcaml_extraction_expressions.gif?inline=false) 44 | 45 | 46 | ## Installation 47 | Gopcaml mode is implemented using a mixture of ocaml and elisp. 48 | 49 | Make sure your emacs is compiled with dynamic modules support (you may need to build emacs from source with the `--with-modules` option). 50 | 51 | *Note:* If you get an error about ELF headers this means that your emacs doesn't support dynamic modules - you'll need to build emacs from source (takes ~5 minutes usually). 52 | 53 | - Install the project via opam: 54 | ```sh 55 | opam install gopcaml-mode 56 | ``` 57 | - install merlin, ocp-indent and tuareg mode 58 | - load the project in your init.el 59 | ```elisp 60 | (let ((opam-share (ignore-errors (car (process-lines "opam" "config" "var" "share"))))) 61 | (when (and opam-share (file-directory-p opam-share)) 62 | ;; Register Gopcaml mode 63 | (add-to-list 'load-path (expand-file-name "emacs/site-lisp" opam-share)) 64 | (autoload 'gopcaml-mode "gopcaml-mode" nil t nil) 65 | (autoload 'tuareg-mode "tuareg" nil t nil) 66 | (autoload 'merlin-mode "merlin" "Merlin mode" t) 67 | ;; Automatically start it in OCaml buffers 68 | (setq auto-mode-alist 69 | (append '(("\\.ml[ily]?$" . gopcaml-mode) 70 | ("\\.topml$" . gopcaml-mode)) 71 | auto-mode-alist)) 72 | )) 73 | ``` 74 | 75 | Enjoy your ultimate editing experience. 76 | 77 | ## Extras 78 | - For some additional features that aren't included in the main release, see the extras folder 79 | ## Development 80 | If you want to tinker with this project/extend it/build your own version, see below: 81 | ### Project Structure 82 | The core project laid out as follows: 83 | ``` 84 | ├── gopcaml.ml 85 | ├── gopcaml_state.ml 86 | ├── ast_zipper.ml 87 | ├── ast_analysis.ml 88 | ├── ast_transformer.ml 89 | ├── gopcaml-mode.el 90 | ├── gopcaml-multiple-cursors.el 91 | └── gopcaml-smartparens.el 92 | 93 | ``` 94 | The purpose of each file is defined as follows (in the order in which you'd probably want to look at them): 95 | - *gopcaml.ml* 96 | - defines the main entrypoint for the module 97 | - this is where all the functions bindings to emacs are setup 98 | - *gopcaml_state.ml* 99 | - defines functions to parse and track a copy of the AST for use in other components 100 | - *ast_zipper.ml* 101 | - defines a huet-style scarred zipper for the OCaml AST. 102 | - the zipper operates in a lazy fashion - i.e the AST is only 103 | expanded into the zipper type when the user expicitly requests it 104 | - *ast_analysis.ml* 105 | - contains functions that perform analysis over the AST (i.e things like finding the free variables in an expression, etc.) 106 | - *ast_transformer.ml* should be moved into here at some point 107 | 108 | - *gopcaml-mode.el* 109 | - main elisp plugin file 110 | - takes the functions exported by gopcaml.ml and provides wrappers to make them more robust 111 | - *gopcaml-\*.el* 112 | - optional features that are loaded in when the required packages are also loaded 113 | - allows for better compatibility with other emacs packages (i.e for 114 | example, disabling ast-movement when at the start of a parens so 115 | smartparens can work ) 116 | 117 | ### Architecture 118 | - There are two main interesting components to gopcaml-mode 119 | - *Tracking OCaml Ast* 120 | - in order to work, gopcaml mode needs to have a copy of the ocaml 121 | ast that (typically*) needs to be up to date with the buffer 122 | contents 123 | - to achieve this while maintaining a fluid user experience this is achieved 124 | through to measures: 125 | - invalidating on changes: 126 | - when any change is made to the buffer, the state is invalidiated 127 | (see `gopcaml_state.ml/State/DirtyRegion/update`) 128 | - if the user runs a command that requires the ast and the ast is 129 | invalidated, then we try and rebuild the ast 130 | (see `gopcaml_state.ml/State/Validated/of_state.ml`). 131 | - periodic rebuilding: 132 | - when gopcaml-mode is started, an idle timer is setup to 133 | periodically check if the AST is out of date and rebuild 134 | it when the user doesn't perform any changes for a while 135 | - this just means that we can perform AST reconstruction 136 | during idle time, and reduces the cost of moving after 137 | changes 138 | *sometimes we don't care if the ast is out of date/we're doing analysis 139 | during a time when we know the ast will not be constructable (i.e for 140 | example if implementing a function to check whether we are writing text 141 | inside a letbinding (see `gopcaml_state.ml/inside_let_def`)) - in this 142 | case we can try and retrieve an old copy of the state 143 | (see `gopcaml_state.ml/State/Validated/of_state_immediate`) 144 | - *Zipper-mode* 145 | - zipper-mode is the terminology given to the transient mode that is 146 | entered when the user performs strucutural movement. 147 | - when a structural command is run for the first time, we retrieve 148 | the ast and create a zipper and store it in a 149 | buffer-local-varaible (see `gopcaml_state.ml/build_zipper_enclosing_point`) 150 | - all subsequent movement commands retrieve the zipper from this variable and 151 | use it to move the emacs cursor and the overlay highlighting the selected item 152 | - transformation operations also use the zipper to update the 153 | buffer, but have to take extra care to ensure that they also 154 | update the state of the zipper to reflect the changes in the ast 155 | (as the zipper, unlike the ast isn't periodically updated) 156 | (see `ast_zipper.ml/move_(left|right|up|down)`) 157 | - when any command that isn't a structural editing one is pressed, 158 | the transient mode ends, and the zipper variable is cleared. 159 | - Note: the fact that the zipper is in a separate variable from the 160 | ast deliberately means that the zipper may become desynchronized 161 | from the ast - for example, if we perform an AST transformation 162 | using the zipper, then the original ast will not be up to 163 | date. This is mainly just to avoid unnecassary work - rather than 164 | writing transformation functions twice for the ast and zipper, we 165 | write them once for the zipper (taking sure to ensure that the 166 | meta-information stored in the zipper is kept up to date), and 167 | then let the automatic rebuilding functionality handle updating 168 | the original ast. 169 | 170 | ### Setting up the development environment 171 | Being an emacs plugin, the development environment setup is tailored 172 | for emacs. 173 | 174 | - Clone the repo from gitlab https://gitlab.com/gopiandcode/gopcaml-mode 175 | - Build the project with `dune build` 176 | - in your init.el where gopmacs is loaded, add the following: 177 | ```elisp 178 | (add-to-list 179 | 'command-switch-alist 180 | (cons "gopdev" (lambda (__) nil))) 181 | 182 | (if (member "-gopdev" command-line-args) (setq gopcaml-dev-mode t)) 183 | 184 | (if (or (not (boundp 'gopcaml-dev-mode)) (not gopcaml-dev-mode)) 185 | ... ;; run normal gopcaml initialization code (i.e from the install instructions) 186 | ) 187 | ``` 188 | - Now launch emacs passing the flag `-gopdev` and open any file inside 189 | the project directory. 190 | - When prompted press `y` or `!` to setup the development variables for the file. 191 | - Now this instance of emacs will use your local branch to load 192 | gopcaml-mode (It's quite nice developing in this way, as any changes 193 | you make will be reflected in your editor, and can quickly be tried 194 | out**. 195 | 196 | Note: My typical development setup is to have a command prompt open in 197 | the background and execute `dune build && emacs -gopdev ./.ml`. 198 | I make some changes, use merlin to ensure there 199 | are no issues, exit and press up on my terminal to reload the prior 200 | command and press enter. 201 | 202 | Note\*: The reason for the complicated setup is that gopcaml-mode uses 203 | dynamic modules to call out to ocaml mode from emacs, and dynamic 204 | modules can only be loaded into an emacs instance once - thus each 205 | time you make a change, you'll need to restart emacs. 206 | 207 | 208 | -------------------------------------------------------------------------------- /text_region.ml: -------------------------------------------------------------------------------- 1 | open Core 2 | open Generic_types 3 | 4 | module Diff = struct 5 | type t = int * int 6 | 7 | let of_pair ~line ~col = (line,col) 8 | 9 | let negate (line,col) = (-line,-col) 10 | 11 | let combine (l1,c1) (l2,c2) = (l1 + l2,c1 + c2) 12 | 13 | let to_string (l1,c1) = Printf.sprintf "(%d,%d)" l1 c1 14 | 15 | (* increments the diff by 1 newline + indentation *) 16 | let add_newline_with_indent ~indent (line,col) = 17 | (line + 1, col + 1 + indent) 18 | 19 | let update_lexing_position (pos: Lexing.position) (line,col) : Lexing.position = 20 | let cnum = match pos.pos_cnum with -1 -> -1 | _ -> max (pos.pos_cnum + col) (-1) in 21 | let lnum = match pos.pos_lnum with -1 -> -1 | _ -> max (pos.pos_lnum + line) (-1) in 22 | {pos with pos_cnum = cnum; pos_lnum = lnum} 23 | 24 | end 25 | 26 | module Position = struct 27 | type t = {line: int; col: int} 28 | 29 | let of_lexing (pos: Lexing.position) : t = 30 | let Lexing.{pos_lnum; pos_cnum; _} = pos in 31 | {line=pos_lnum; col = pos_cnum} 32 | 33 | let (+) {line=l1;col=c1} (line,col) = 34 | let c1 = match c1 with -1 -> -1 | _ -> max (c1 + col) (-1) in 35 | let l1 = match l1 with -1 -> -1 | _ -> max (l1 + line) (-1) in 36 | {line=l1; col = c1} 37 | 38 | let cmp f a b = match (a,b) with 39 | -1,-1 -> -1 40 | | a,-1 -> a 41 | | -1,b -> b 42 | | a,b -> f a b 43 | let min = cmp min 44 | let max = cmp max 45 | 46 | let min {line=l1;col=c1} {line=l2;col=c2} = 47 | {line=min l1 l2; col=min c1 c2} 48 | 49 | let max {line=l1;col=c1} {line=l2;col=c2} = 50 | {line=max l1 l2; col=max c1 c2} 51 | 52 | end 53 | 54 | type pos = Position.t 55 | 56 | type t = (pos[@opaque]) * (pos[@opaque]) 57 | 58 | let to_bounds Position.({col=cs;_},{col=ce; _}) = (cs,ce) 59 | 60 | let to_string Position.({col=cs;line=ls},{col=ce; line=le}) = 61 | Printf.sprintf "{col: %d - %d; line: %d - %d}" cs ce ls le 62 | 63 | let pp = to_string 64 | 65 | let shift_region (r_start, r_end) shift = 66 | let open Position in 67 | r_start + shift, r_end + shift 68 | 69 | let extend_region (r_start, r_end) shift = 70 | let open Position in 71 | r_start, r_end + shift 72 | 73 | let of_location (loc :Location.t) : t = 74 | let st = Position.of_lexing loc.loc_start in 75 | let ed = Position.of_lexing loc.loc_end in 76 | (st,ed) 77 | 78 | let union (st1,ed1) (st2,ed2) = 79 | let open Position in 80 | let (st1,ed1) = min st1 ed1, max st1 ed1 in 81 | let (st2,ed2) = min st2 ed2, max st2 ed2 in 82 | (Position.min st1 st2),(Position.max ed1 ed2) 83 | 84 | let ast_bounds_iterator () = 85 | let bounds = ref None in 86 | let retrieve_bounds () = Option.value_exn !bounds in 87 | let update_bounds pstr_loc = 88 | let new_bounds = of_location pstr_loc in 89 | let new_bounds = match !bounds with 90 | | None -> new_bounds 91 | | Some old_bounds -> union old_bounds new_bounds in 92 | bounds := Some new_bounds 93 | in 94 | Ast_iterator.{ 95 | default_iterator 96 | with 97 | location = fun _ -> update_bounds 98 | }, retrieve_bounds 99 | 100 | let ast_bounds_mapper ~diff = 101 | {Ast_mapper.default_mapper with 102 | location = (fun _ ({ loc_start; loc_end; _ } as loc) -> 103 | {loc with 104 | loc_start= Diff.update_lexing_position loc_start diff; 105 | loc_end= Diff.update_lexing_position loc_end diff; } 106 | ) } 107 | 108 | let before_point (({ col=c1; _ },_):t) point = 109 | match c1 with 110 | | -1 -> false 111 | | a -> 112 | point < a 113 | 114 | let contains_point (({ col=c1; _ },{ col=c2; _ }):t) point = 115 | match c1,c2 with 116 | | -1,-1 | -1, _ | _, -1 -> false 117 | | a, b -> 118 | a <= point && point <= b 119 | 120 | let contains_ne_point (({ col=c1; _ },{ col=c2; _ }):t) point = 121 | match c1,c2 with 122 | | -1,-1 | -1, _ | _, -1 -> false 123 | | a, b -> a < point && point < b 124 | 125 | 126 | let equals_point ?forward (({ col=c1; _ },{ col=c2; _ }):t) point = 127 | match c1,c2 with 128 | | -1,-1 | -1, _ | _, -1 -> false 129 | | a, b -> 130 | match forward with 131 | | Some true -> a = point 132 | | Some false -> b = point 133 | | _ -> a = point || point = b 134 | 135 | 136 | let distance ?forward (({ col=c1; _ },{ col=c2; _ }):t) point = 137 | match c1,c2 with 138 | | -1,-1 | -1, _ | _, -1 -> None 139 | | start, ed -> 140 | match forward with 141 | | Some true -> Some (abs (start - point)) 142 | | Some false -> Some (abs (ed - point)) 143 | | _ -> Some (min (abs (start - point)) (abs (ed - point))) 144 | 145 | let distance_line ?forward (({ col=c1; line=l1 },{ col=c2; line=l2 }):t) ~point ~line = 146 | let diff c1 c2 point = match c1,c2 with 147 | | -1,-1 | -1, _ | _, -1 -> None 148 | | start, ed -> 149 | match forward with 150 | | None -> Some (min (abs (start - point)) (abs (ed - point))) 151 | | Some true -> Some (abs (start - point)) 152 | | Some false -> Some (abs (ed - point)) 153 | in 154 | let diff_line c1 c2 point = match c1,c2 with 155 | | -1,-1 | -1, _ | 0,0 | 0,_ | _,0 | _, -1 -> None 156 | | start, ed -> 157 | match forward with 158 | | None -> Some (min (abs (start - point)) (abs (ed - point))) 159 | | Some true -> Some (abs (start - point)) 160 | | Some false -> Some (abs (ed - point)) 161 | in 162 | let col_diff = diff c1 c2 point in 163 | let line_diff = diff_line l1 l2 line in 164 | (col_diff, line_diff) 165 | 166 | let line_start (({ line=l1; _ },_):t) = l1 167 | 168 | (* let line_end ((_,{ line=l1; _ }):t) = l1 *) 169 | 170 | let column_start (({ col=c1; _ },_):t) = c1 171 | 172 | let column_end ((_,{ col=c1; _ }):t) = c1 173 | 174 | let to_diff (({ line=l1; col=c1; },{ line=l2; col=c2; }): t) = 175 | let (>>=) x f = Option.bind ~f x in 176 | let unwrap vl = match vl with -1 -> None | v -> Some v in 177 | (unwrap l1) >>= fun l1 -> 178 | (unwrap l2) >>= fun l2 -> 179 | (unwrap c1) >>= fun c1 -> 180 | (unwrap c2) >>= fun c2 -> 181 | Some (l1 - l2, c1 - c2) 182 | 183 | let swap_diff 184 | (({ line=a_l1; col=a_c1; },{ line=a_l2; col=a_c2; }): t) 185 | (({ line=b_l1; col=b_c1; },{ line=b_l2; col=b_c2; }): t) = 186 | let (>>=) x f = Option.bind ~f x in 187 | let unwrap vl = match vl with -1 -> None | v -> Some v in 188 | (unwrap a_l1) >>= fun a_l1 -> 189 | (unwrap a_l2) >>= fun a_l2 -> 190 | (unwrap a_c1) >>= fun a_c1 -> 191 | (unwrap a_c2) >>= fun a_c2 -> 192 | (unwrap b_l1) >>= fun b_l1 -> 193 | (unwrap b_l2) >>= fun b_l2 -> 194 | (unwrap b_c1) >>= fun b_c1 -> 195 | (unwrap b_c2) >>= fun b_c2 -> 196 | let forward_shift = (a_l2 - b_l2, a_c2 - b_c2) in 197 | let backwards_shift = (b_l1 - a_l1, b_c1 - a_c1) in 198 | Some (forward_shift,backwards_shift) 199 | 200 | let diff_between 201 | ((_, { line=a_l1; col=a_c1; }): t) 202 | (({ line=b_l1; col=b_c1; }, _): t) = 203 | let (>>=) x f = Option.bind ~f x in 204 | let unwrap vl = match vl with -1 -> None | v -> Some v in 205 | (unwrap a_l1) >>= fun a_l1 -> 206 | (unwrap a_c1) >>= fun a_c1 -> 207 | (unwrap b_l1) >>= fun b_l1 -> 208 | (unwrap b_c1) >>= fun b_c1 -> 209 | let backwards_shift = (a_l1 - b_l1, a_c1 - b_c1) in 210 | Some (backwards_shift) 211 | 212 | 213 | let to_shift_from_start ((_,{ line=a_l2; col=a_c2; }): t) = 214 | (a_l2,a_c2) 215 | 216 | -------------------------------------------------------------------------------- /text_region.mli: -------------------------------------------------------------------------------- 1 | open Generic_types 2 | 3 | module Diff : sig 4 | type t 5 | val of_pair : line:int -> col:int -> t 6 | val combine : t -> t -> t 7 | val to_string : t -> string 8 | val add_newline_with_indent: indent:int -> t -> t 9 | val negate : t -> t 10 | val update_lexing_position : Lexing.position -> t -> Lexing.position 11 | end 12 | 13 | type t 14 | 15 | val of_location: Location.t -> t 16 | 17 | val to_bounds : t -> (int * int) 18 | 19 | val to_string : t -> string 20 | 21 | val pp : t -> string 22 | 23 | val shift_region : t -> Diff.t -> t 24 | 25 | val extend_region : t -> Diff.t -> t 26 | 27 | val union : t -> t -> t 28 | 29 | val before_point : t -> int -> bool 30 | 31 | val contains_point : t -> int -> bool 32 | 33 | val contains_ne_point : t -> int -> bool 34 | 35 | val equals_point : ?forward:bool -> t -> int -> bool 36 | 37 | val ast_bounds_iterator : unit -> Ast_iterator.iterator * (unit -> t) 38 | 39 | val ast_bounds_mapper : diff:Diff.t -> Ast_mapper.mapper 40 | 41 | val distance : ?forward:bool -> t -> int -> int option 42 | 43 | val distance_line : ?forward:bool -> t -> point:int -> line:int -> (int option * int option) 44 | 45 | val line_start : t -> int 46 | 47 | val column_start : t -> int 48 | 49 | val column_end : t -> int 50 | 51 | val to_diff : t -> Diff.t option 52 | 53 | val swap_diff : t -> t -> (Diff.t * Diff.t) option 54 | 55 | val diff_between : t -> t -> Diff.t option 56 | 57 | val to_shift_from_start: t -> Diff.t 58 | 59 | -------------------------------------------------------------------------------- /todo.org: -------------------------------------------------------------------------------- 1 | * Todo 2 | ** DONE Update temporary highlight function to be less convoluted 3 | CLOSED: [2020-02-12 Wed 13:53] 4 | ** DONE Rebuild parse tree on changes 5 | CLOSED: [2020-02-14 Fri 12:59] 6 | *** use after-change-functions to track changed location :elisp: 7 | *** use idle timer to queue update :elisp: 8 | *** setup function to rebuild region of parse tree :ocaml: 9 | **** split list into three - before, in and after region 10 | **** parse edited region and replace in section 11 | **** otherwise, parse from start to eof and replace in and after 12 | **** otherwise, reparse file 13 | **** DONE otherwise drop changes 14 | CLOSED: [2020-02-14 Fri 12:59] 15 | ** DONE Implement highlight current expression 16 | CLOSED: [2020-02-14 Fri 13:28] 17 | *** Iterate through structure item, find nearest enclosing bounds 18 | ** DONE Write zipper for AST 19 | CLOSED: [2020-02-14 Fri 18:23] 20 | ** DONE Implement go to parent 21 | CLOSED: [2020-02-14 Fri 18:22] 22 | *** use zipper to move to parent 23 | ** DONE Use set-transient-map to implement a tmm 24 | CLOSED: [2020-02-14 Fri 18:22] 25 | ** DONE Swap code regions at the same level 26 | CLOSED: [2020-02-14 Fri 17:05] 27 | *** use zipper to find bounds for both regions 28 | *** perform swap in emacs using marker to remember the insert positions 29 | ** DONE Figure out how to include comments in enclosed region 30 | CLOSED: [2020-02-15 Sat 18:06] 31 | ** DONE Implement move up move down (rather than transpose) 32 | CLOSED: [2020-02-15 Sat 11:10] 33 | ** DONE make zipper move to nearest enclosing scope on activation 34 | CLOSED: [2020-02-15 Sat 12:05] 35 | ** DONE integrate with merlin types (i.e print type of current zipper) 36 | CLOSED: [2020-02-15 Sat 12:20] 37 | ** DONE Goto nearest structure item (for C-M-a (tuareg is screwed up)) 38 | CLOSED: [2020-02-17 Mon 18:06] 39 | ** DONE Fix issue with empty structures 40 | CLOSED: [2020-02-18 Tue 11:43] 41 | ** DONE Track lines in zipper 42 | CLOSED: [2020-02-18 Tue 13:20] 43 | ** DONE Remove type holes on edit 44 | CLOSED: [2020-02-18 Tue 18:57] 45 | ** DONE Add insertion capability? 46 | CLOSED: [2020-02-18 Tue 18:57] 47 | ** DONE Fix move to defun functionality to use lines 48 | CLOSED: [2020-02-19 Wed 12:01] 49 | ** DONE Setup move to let def to begin zipper mode 50 | CLOSED: [2020-02-21 Fri 17:10] 51 | *** DONE C-M-a - move to start of defun & move zipper broadly to point and start zipper at structure item 52 | CLOSED: [2020-02-19 Wed 15:09] 53 | *** DONE C-M-e - move to end of defun & move zipper broadly to point and start zipper at structure item 54 | CLOSED: [2020-02-19 Wed 15:09] 55 | *** DONE C-M-u - backwards up list - move granularly to region, and move up zipper 56 | CLOSED: [2020-02-19 Wed 17:17] 57 | *** DONE C-M-u - backwards up list - move granularly to region, and move down zipper 58 | CLOSED: [2020-02-19 Wed 17:17] 59 | *** DONE - list expressions move forward without expanding the element 60 | CLOSED: [2020-02-19 Wed 17:17] 61 | **** DONE C-M-n - forwards list - move broadly to region and move left zipper 62 | CLOSED: [2020-02-19 Wed 17:17] 63 | **** DONE C-M-p - backwards list - move broadly to region and move left zipper 64 | CLOSED: [2020-02-19 Wed 17:17] 65 | *** DONE - forwards expressions attempt to expand the item below it 66 | CLOSED: [2020-02-19 Wed 17:17] 67 | **** DONE C-M-f - forwards sexp - move granularly to region and move forward zipper 68 | CLOSED: [2020-02-19 Wed 17:17] 69 | **** DONE C-M-b - backwards sexp - move granularly to region and move backwards zipper 70 | CLOSED: [2020-02-19 Wed 17:17] 71 | *** DONE Fix issue with line 0 72 | CLOSED: [2020-02-20 Thu 13:55] 73 | *** DONE Setup adding remove parens in pairs 74 | CLOSED: [2020-02-20 Thu 16:24] 75 | *** DONE Setup conditional keybindings 76 | CLOSED: [2020-02-21 Fri 17:10] 77 | **** add filter function to check whether state active, and try to build - return nil if state still not possible 78 | **** use menu-item to only bind movement commands when possible to build zipper 79 | ** DONE add support for selections 80 | CLOSED: [2020-02-21 Fri 18:23] 81 | *** shift-commands - don't place a face on the overlay 82 | ** DONE C-M-t fix transpose sexp 83 | CLOSED: [2020-02-21 Fri 12:33] 84 | ** DONE Fix whitespace 85 | CLOSED: [2020-02-21 Fri 19:14] 86 | ** DONE Support move out of region 87 | CLOSED: [2020-02-21 Fri 19:14] 88 | ** DONE Implement move into 89 | CLOSED: [2020-02-21 Fri 19:15] 90 | ** DONE Implement move outof 91 | CLOSED: [2020-02-21 Fri 19:15] 92 | 93 | ** TODO Support zipper to range 94 | ** TODO Implement refactoring 95 | * Inessential todos 96 | ** TODO - move zipper to point and kill 97 | *** DONE C-M-k - kill sexp 98 | CLOSED: [2020-02-19 Wed 17:17] 99 | *** TODO C-M-spc - mark sexp - move zipper to point and select region 100 | ** TODO M-{, M-} - move paragraph - (i.e top level structure items) 101 | ** TODO M-a, M-e - move sentences - module 102 | ** TODO M-k - kill sentence - kill module 103 | ** TODO C-M-l reposition to buffer - fix to work with ocaml 104 | * Longer term Todos 105 | ** DONE move to (??) type holes with C-n C-p if present in function DWIM 106 | CLOSED: [2021-08-18 Wed 11:22] 107 | *** Write function to check if current buffer contains any type holes 108 | *** Write function to return position of next type hole 109 | ** DONE add expression and more functionality to zipper 110 | CLOSED: [2021-08-18 Wed 11:22] 111 | ** DONE integrate with merlin (d)estruct/(l)ocate 112 | CLOSED: [2021-08-18 Wed 11:22] 113 | ** DONE Extract binding 114 | CLOSED: [2021-08-18 Wed 11:22] 115 | ** DONE Highlight regions 116 | CLOSED: [2021-08-18 Wed 11:22] 117 | *** Add function to find all repetitions of enclosing expression 118 | *** add function to highlight all these bounds temporarily 119 | *** add-on-idle function to run highlight on delay 120 | * Gopcaml-mode Ideas 121 | ** Better move to defun recognition 122 | *** If point on the same line, then use current item 123 | *** Use line distance rather than character distance (makes more sense) 124 | *** In case of tie then use column 125 | * Tasks 126 | ** DONE Implement customisable logging 127 | CLOSED: [2021-08-18 Wed 14:03] 128 | *** Setup variable to track logging 129 | *** Create logging variable 130 | -------------------------------------------------------------------------------- /todo.org_archive: -------------------------------------------------------------------------------- 1 | # -*- mode: org -*- 2 | 3 | 4 | Archived entries from file /home/kirang/Documents/code/ocaml/gopcaml-mode/todo.org 5 | 6 | 7 | * Implement refactoring 8 | :PROPERTIES: 9 | :ARCHIVE_TIME: 2020-03-04 Wed 19:29 10 | :ARCHIVE_FILE: ~/Documents/code/ocaml/gopcaml-mode/todo.org 11 | :ARCHIVE_OLPATH: Todo 12 | :ARCHIVE_CATEGORY: todo 13 | :END: 14 | --------------------------------------------------------------------------------