pax_global_header 0000666 0000000 0000000 00000000064 14315315656 0014523 g ustar 00root root 0000000 0000000 52 comment=4d94293cc5a7bba6cd043e29968719ce597d65f5
tuareg-3.0.1/ 0000775 0000000 0000000 00000000000 14315315656 0013013 5 ustar 00root root 0000000 0000000 tuareg-3.0.1/.dir-locals.el 0000664 0000000 0000000 00000000061 14315315656 0015441 0 ustar 00root root 0000000 0000000 ((emacs-lisp-mode . ((indent-tabs-mode . nil))))
tuareg-3.0.1/.github/ 0000775 0000000 0000000 00000000000 14315315656 0014353 5 ustar 00root root 0000000 0000000 tuareg-3.0.1/.github/workflows/ 0000775 0000000 0000000 00000000000 14315315656 0016410 5 ustar 00root root 0000000 0000000 tuareg-3.0.1/.github/workflows/test.yml 0000664 0000000 0000000 00000001216 14315315656 0020112 0 ustar 00root root 0000000 0000000 name: test
on:
push:
paths-ignore:
- '*.md'
- 'COPYING'
- 'HISTORY'
pull_request:
paths-ignore:
- '*.md'
- 'COPYING'
- 'HISTORY'
jobs:
test:
runs-on: ubuntu-latest
strategy:
matrix:
emacs_version:
- "26.3"
- "27.2"
- "28.1"
- snapshot
steps:
- name: Set up Emacs
uses: purcell/setup-emacs@master
with:
version: ${{matrix.emacs_version}}
- name: Check out tuareg
uses: actions/checkout@v2
- name: Byte-compile
run: make elc-werror
- name: Test
run: make check
tuareg-3.0.1/.gitignore 0000664 0000000 0000000 00000000162 14315315656 0015002 0 ustar 00root root 0000000 0000000 *.elc
*.test
*-autoloads.el
*-pkg.el
*~
*.tar.gz
packages
/tuareg.*/
ChangeLog
tuareg-site-file.el
tuareg.install
tuareg-3.0.1/CHANGES.md 0000664 0000000 0000000 00000017205 14315315656 0014412 0 ustar 00root root 0000000 0000000 3.0 2022-09-27
--------------
Backward incompatible changes are marked with “⚠”.
* New option `tuareg-mode-line-other-file`.
* New mode `tuareg-menhir-mode`.
Note that C-c C-c launches the compilation.
* ⚠ `tuareg-eval-phrase` (C-c C-e and C-x C-e) now
evaluate the smallest set of phrases containing the region if the
latter is active.
* ⚠ `tuareg-eval-phrase` now skips `;;` even on a separate line when moving
forward. This permits quick evaluation of multiple phrases in succession.
* ⚠ `tuareg-eval-region` (C-c C-r): only send the content of
the region to the REPL.
* Be more subtle in phrase detection.
* Bogus mismatched parentheses at the end of comment fixed.
* ⚠ `show-paren-mode`: also highlight comment delimiters. You can
turn that off by setting `tuareg-comment-show-paren` to `nil`.
* Syntax highlighting improvements: much faster; much better highlighting
of function, class, and method arguments (including setting the
`font-lock-multiline` property); `[]` and `::` have the constructor
face; first class module, `type nonrec`, `raise_notrace`, `with
type` are handled. Finer highlighting of infix operators. Support
for [binding operators][]. Moreover, font-lock now has 3 possible
levels of fontification (see the README).
* The switch .ml ↔ .mli now uses the Emacs built-in `find-file` and
was extended to `.eliom` ↔ `.eliomi` and `.mly` ↔ `.mli`. It also
works for pre-processed files named `.pp.ml` and `.pp.mli`.
* When switching from an `.ml` to a non-existing `.mli` file using
C-c C-a, one is offered to fill the `.mli` buffer with the
generated interface.
* Set `beginning-of-defun-function` and `end-of-defun-function` which
allows to go to the beginning of the current function (resp. end)
with C-M-home, C-M-a or ESC
C-home (resp. C-M-end, C-M-e, or
ESC C-end).
* ⚠ `beginning-of-defun` (C-M-a, C-M-home) is
now repeatable. Previously it would not move the cursor if invoked
at the beginning of a defun. Now it goes to the start of the
previous defun, which is the standard in Emacs and generally more
useful.
* ⚠ Movement by defun now considers `and` clauses of a `type` or
declarative `let` to be defuns in their own right, since that's
closer to how programmers think. This generally makes defun-based
operations more useful.
* ⚠ `tuareg-comment-dwim` is now bound to C-c C-; (fixes #149).
* Fix the highlighting of errors locations in interactive mode.
* ocamldebug: Handle correctly the new code pointer format (issue #205).
* Rework electric functions (fixes issues #150 and #162).
* Update the compilation regexp to detect warnings and errors for the
OCaml ≥ 4.08 (fixes #202).
* Autoload compilation error regexp so it is correct even if Tuareg
was not loaded.
* Messages from recent OCaml compiler versions are now parsed
correctly for severity and source location. This includes precise
parsing of the location start and end columns. Exception backtraces
are now also recognised.
* Ancillary locations are now treated as Info-level messages, not
errors in their own right. This way they no longer contribute to
Emacs's compilation-mode error count, but they will be ignored by
`next-error` and `previous-error`. Set `compilation-skip-threshold`
to `0` if you want `next-error` to step into these locations.
* Evaluation of phrases: evaluate the above phrase if the point is in
or after comments immediately following the let-binding (without
separating blank lines).
* Better indentation of empty lines (fixes #179).
* Use a pty to communicate with the `ocaml` process (fixes #83).
* `tuareg-opam`: syntax highlighting updates.
* ⚠ Remove `tuareg-light`, you should now use `tuareg`.
* `class type` is now parsed correctly (#239).
* Improved indentation of class definition with non-hanging `object` (#239).
The new behaviour agrees with ocp-indent and seems to be the more modern
usage. `initialize` clauses are also indented correctly.
* Better default colour for extension nodes on dark background.
`tuareg-font-lock-extension-node-face` was nigh-unreadable against
a dark background. The face now uses the default background colour.
* Ocamldoc `(** ... *)` comments are now fontified by their structure.
This makes markup constructs stand out in order to improve legibility
and reduces the risk of mistakes. The body text is set in
`font-lock-doc-face` as before; mark-up constructs use
`tuareg-font-lock-doc-markup-face`, which defaults to
`font-lock-doc-markup-face` (new in Emacs 28) if available.
Note that the mode `tuareg-dune` which was in the development version
of this package is now part of [Dune](https://github.com/ocaml/dune).
[binding operators]: https://v2.ocaml.org/releases/4.08/htmlman/index.html
2.1.0 2017-11-10
----------------
* Let M-q reformat strings (and use only SMIE).
* Do not indent an expression after `;;` (issue #106).
* New face `tuareg-font-double-colon-face` to highlight `;;`.
* For `type … and …`, left-align `and` with `type`.
* Fix indentation of some GADT type definitions.
* Use `prettify-symbols-mode` to turn `+.` into `∔`,… and add a menu
entry to toggle it.
* Properly indent `type 'a foo = 'a bla = …` (issue #98).
* Properly indent (issue #7):
module … with module X = Z
and type t := C.t
* Support `let exception E in expr` (issue #102).
* Improved highlighting of `val` and `module` in first class module
expressions.
* Warn if a file inside a `_build` is edited and propose to switch.
* Add a custom face `tuareg-font-lock-label-face` for labels.
* Add option `tuareg-match-patterns-aligned` to allow to choose
between the two styles:
function v.s. function
| A | A
| B -> ... | B -> ...
| C -> ... | C -> ... "
* Highlight attributes and extension nodes.
* Disable by default and improve the compilation advice—see the new
variable `tuareg-opam-insinuate` (issue #97).
* New keybinding C-cC-w and function `tuareg-opam-update-env`
to update the environment to an opam switch (offering completion).
* Improved highlighting of quoted strings `{|…|}` (issue #89).
* Move after `;;` when evaluating a phrase in the toploop (issue #96).
* ocamldebug:
- Add support for `completion-at-point`.
- Highlight the right location even in presence of non-ascii chars
(issue #80).
- Make possible to pass argument to ocamldebug (say, paths with `-I`).
- Make possible to pass argument to the program being debugged (issue #66).
- Warn if SMIE is disabled.
* New modes `tuareg-jbuild` and `tuareg-opam` with syntax
highlighting, indentation, and skeletons.
2.0.10
------
* New indentation config var for SMIE: tuareg-indent-align-with-first-arg.
* Many indentation improvements.
* Fixed point jumping in ocamldebug completion (by Darius Foo).
* Improved (var: t) syntax highlighting.
* Color all predefined exceptions with font-lock-builtin-face
* Syntax highlight cppo preprocessor directives.
2.0.9
-----
* Do not activate Tuareg for .mll and .mly files.
* Toplevel prompt is readonly.
* Font-lock code completely rewritten (avoids several hangs). New faces
`tuareg-font-lock-module-face', `tuareg-font-lock-constructor-face',
and `tuareg-font-lock-line-number-face'.
* Non-closed comment does not cause M-q to hang.
* New variables `caml-types-build-dirs' and `caml-types-annot-dir' for
a more versatile specification of .annot files. (Submitted back to
caml-mode.)
* Fix toplevel highlighting of output and errors.
tuareg-3.0.1/COPYING 0000664 0000000 0000000 00000104515 14315315656 0014054 0 ustar 00root root 0000000 0000000 GNU GENERAL PUBLIC LICENSE
Version 3, 29 June 2007
Copyright (C) 2007 Free Software Foundation, Inc.
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The GNU General Public License is a free, copyleft license for
software and other kinds of works.
The licenses for most software and other practical works are designed
to take away your freedom to share and change the works. By contrast,
the GNU General Public License is intended to guarantee your freedom to
share and change all versions of a program--to make sure it remains free
software for all its users. We, the Free Software Foundation, use the
GNU General Public License for most of our software; it applies also to
any other work released this way by its authors. You can apply it to
your programs, too.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
them if you wish), that you receive source code or can get it if you
want it, that you can change the software or use pieces of it in new
free programs, and that you know you can do these things.
To protect your rights, we need to prevent others from denying you
these rights or asking you to surrender the rights. Therefore, you have
certain responsibilities if you distribute copies of the software, or if
you modify it: responsibilities to respect the freedom of others.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must pass on to the recipients the same
freedoms that you received. You must make sure that they, too, receive
or can get the source code. And you must show them these terms so they
know their rights.
Developers that use the GNU GPL protect your rights with two steps:
(1) assert copyright on the software, and (2) offer you this License
giving you legal permission to copy, distribute and/or modify it.
For the developers' and authors' protection, the GPL clearly explains
that there is no warranty for this free software. For both users' and
authors' sake, the GPL requires that modified versions be marked as
changed, so that their problems will not be attributed erroneously to
authors of previous versions.
Some devices are designed to deny users access to install or run
modified versions of the software inside them, although the manufacturer
can do so. This is fundamentally incompatible with the aim of
protecting users' freedom to change the software. The systematic
pattern of such abuse occurs in the area of products for individuals to
use, which is precisely where it is most unacceptable. Therefore, we
have designed this version of the GPL to prohibit the practice for those
products. If such problems arise substantially in other domains, we
stand ready to extend this provision to those domains in future versions
of the GPL, as needed to protect the freedom of users.
Finally, every program is threatened constantly by software patents.
States should not allow patents to restrict development and use of
software on general-purpose computers, but in those that do, we wish to
avoid the special danger that patents applied to a free program could
make it effectively proprietary. To prevent this, the GPL assures that
patents cannot be used to render the program non-free.
The precise terms and conditions for copying, distribution and
modification follow.
TERMS AND CONDITIONS
0. Definitions.
"This License" refers to version 3 of the GNU General Public License.
"Copyright" also means copyright-like laws that apply to other kinds of
works, such as semiconductor masks.
"The Program" refers to any copyrightable work licensed under this
License. Each licensee is addressed as "you". "Licensees" and
"recipients" may be individuals or organizations.
To "modify" a work means to copy from or adapt all or part of the work
in a fashion requiring copyright permission, other than the making of an
exact copy. The resulting work is called a "modified version" of the
earlier work or a work "based on" the earlier work.
A "covered work" means either the unmodified Program or a work based
on the Program.
To "propagate" a work means to do anything with it that, without
permission, would make you directly or secondarily liable for
infringement under applicable copyright law, except executing it on a
computer or modifying a private copy. Propagation includes copying,
distribution (with or without modification), making available to the
public, and in some countries other activities as well.
To "convey" a work means any kind of propagation that enables other
parties to make or receive copies. Mere interaction with a user through
a computer network, with no transfer of a copy, is not conveying.
An interactive user interface displays "Appropriate Legal Notices"
to the extent that it includes a convenient and prominently visible
feature that (1) displays an appropriate copyright notice, and (2)
tells the user that there is no warranty for the work (except to the
extent that warranties are provided), that licensees may convey the
work under this License, and how to view a copy of this License. If
the interface presents a list of user commands or options, such as a
menu, a prominent item in the list meets this criterion.
1. Source Code.
The "source code" for a work means the preferred form of the work
for making modifications to it. "Object code" means any non-source
form of a work.
A "Standard Interface" means an interface that either is an official
standard defined by a recognized standards body, or, in the case of
interfaces specified for a particular programming language, one that
is widely used among developers working in that language.
The "System Libraries" of an executable work include anything, other
than the work as a whole, that (a) is included in the normal form of
packaging a Major Component, but which is not part of that Major
Component, and (b) serves only to enable use of the work with that
Major Component, or to implement a Standard Interface for which an
implementation is available to the public in source code form. A
"Major Component", in this context, means a major essential component
(kernel, window system, and so on) of the specific operating system
(if any) on which the executable work runs, or a compiler used to
produce the work, or an object code interpreter used to run it.
The "Corresponding Source" for a work in object code form means all
the source code needed to generate, install, and (for an executable
work) run the object code and to modify the work, including scripts to
control those activities. However, it does not include the work's
System Libraries, or general-purpose tools or generally available free
programs which are used unmodified in performing those activities but
which are not part of the work. For example, Corresponding Source
includes interface definition files associated with source files for
the work, and the source code for shared libraries and dynamically
linked subprograms that the work is specifically designed to require,
such as by intimate data communication or control flow between those
subprograms and other parts of the work.
The Corresponding Source need not include anything that users
can regenerate automatically from other parts of the Corresponding
Source.
The Corresponding Source for a work in source code form is that
same work.
2. Basic Permissions.
All rights granted under this License are granted for the term of
copyright on the Program, and are irrevocable provided the stated
conditions are met. This License explicitly affirms your unlimited
permission to run the unmodified Program. The output from running a
covered work is covered by this License only if the output, given its
content, constitutes a covered work. This License acknowledges your
rights of fair use or other equivalent, as provided by copyright law.
You may make, run and propagate covered works that you do not
convey, without conditions so long as your license otherwise remains
in force. You may convey covered works to others for the sole purpose
of having them make modifications exclusively for you, or provide you
with facilities for running those works, provided that you comply with
the terms of this License in conveying all material for which you do
not control copyright. Those thus making or running the covered works
for you must do so exclusively on your behalf, under your direction
and control, on terms that prohibit them from making any copies of
your copyrighted material outside their relationship with you.
Conveying under any other circumstances is permitted solely under
the conditions stated below. Sublicensing is not allowed; section 10
makes it unnecessary.
3. Protecting Users' Legal Rights From Anti-Circumvention Law.
No covered work shall be deemed part of an effective technological
measure under any applicable law fulfilling obligations under article
11 of the WIPO copyright treaty adopted on 20 December 1996, or
similar laws prohibiting or restricting circumvention of such
measures.
When you convey a covered work, you waive any legal power to forbid
circumvention of technological measures to the extent such circumvention
is effected by exercising rights under this License with respect to
the covered work, and you disclaim any intention to limit operation or
modification of the work as a means of enforcing, against the work's
users, your or third parties' legal rights to forbid circumvention of
technological measures.
4. Conveying Verbatim Copies.
You may convey verbatim copies of the Program's source code as you
receive it, in any medium, provided that you conspicuously and
appropriately publish on each copy an appropriate copyright notice;
keep intact all notices stating that this License and any
non-permissive terms added in accord with section 7 apply to the code;
keep intact all notices of the absence of any warranty; and give all
recipients a copy of this License along with the Program.
You may charge any price or no price for each copy that you convey,
and you may offer support or warranty protection for a fee.
5. Conveying Modified Source Versions.
You may convey a work based on the Program, or the modifications to
produce it from the Program, in the form of source code under the
terms of section 4, provided that you also meet all of these conditions:
a) The work must carry prominent notices stating that you modified
it, and giving a relevant date.
b) The work must carry prominent notices stating that it is
released under this License and any conditions added under section
7. This requirement modifies the requirement in section 4 to
"keep intact all notices".
c) You must license the entire work, as a whole, under this
License to anyone who comes into possession of a copy. This
License will therefore apply, along with any applicable section 7
additional terms, to the whole of the work, and all its parts,
regardless of how they are packaged. This License gives no
permission to license the work in any other way, but it does not
invalidate such permission if you have separately received it.
d) If the work has interactive user interfaces, each must display
Appropriate Legal Notices; however, if the Program has interactive
interfaces that do not display Appropriate Legal Notices, your
work need not make them do so.
A compilation of a covered work with other separate and independent
works, which are not by their nature extensions of the covered work,
and which are not combined with it such as to form a larger program,
in or on a volume of a storage or distribution medium, is called an
"aggregate" if the compilation and its resulting copyright are not
used to limit the access or legal rights of the compilation's users
beyond what the individual works permit. Inclusion of a covered work
in an aggregate does not cause this License to apply to the other
parts of the aggregate.
6. Conveying Non-Source Forms.
You may convey a covered work in object code form under the terms
of sections 4 and 5, provided that you also convey the
machine-readable Corresponding Source under the terms of this License,
in one of these ways:
a) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by the
Corresponding Source fixed on a durable physical medium
customarily used for software interchange.
b) Convey the object code in, or embodied in, a physical product
(including a physical distribution medium), accompanied by a
written offer, valid for at least three years and valid for as
long as you offer spare parts or customer support for that product
model, to give anyone who possesses the object code either (1) a
copy of the Corresponding Source for all the software in the
product that is covered by this License, on a durable physical
medium customarily used for software interchange, for a price no
more than your reasonable cost of physically performing this
conveying of source, or (2) access to copy the
Corresponding Source from a network server at no charge.
c) Convey individual copies of the object code with a copy of the
written offer to provide the Corresponding Source. This
alternative is allowed only occasionally and noncommercially, and
only if you received the object code with such an offer, in accord
with subsection 6b.
d) Convey the object code by offering access from a designated
place (gratis or for a charge), and offer equivalent access to the
Corresponding Source in the same way through the same place at no
further charge. You need not require recipients to copy the
Corresponding Source along with the object code. If the place to
copy the object code is a network server, the Corresponding Source
may be on a different server (operated by you or a third party)
that supports equivalent copying facilities, provided you maintain
clear directions next to the object code saying where to find the
Corresponding Source. Regardless of what server hosts the
Corresponding Source, you remain obligated to ensure that it is
available for as long as needed to satisfy these requirements.
e) Convey the object code using peer-to-peer transmission, provided
you inform other peers where the object code and Corresponding
Source of the work are being offered to the general public at no
charge under subsection 6d.
A separable portion of the object code, whose source code is excluded
from the Corresponding Source as a System Library, need not be
included in conveying the object code work.
A "User Product" is either (1) a "consumer product", which means any
tangible personal property which is normally used for personal, family,
or household purposes, or (2) anything designed or sold for incorporation
into a dwelling. In determining whether a product is a consumer product,
doubtful cases shall be resolved in favor of coverage. For a particular
product received by a particular user, "normally used" refers to a
typical or common use of that class of product, regardless of the status
of the particular user or of the way in which the particular user
actually uses, or expects or is expected to use, the product. A product
is a consumer product regardless of whether the product has substantial
commercial, industrial or non-consumer uses, unless such uses represent
the only significant mode of use of the product.
"Installation Information" for a User Product means any methods,
procedures, authorization keys, or other information required to install
and execute modified versions of a covered work in that User Product from
a modified version of its Corresponding Source. The information must
suffice to ensure that the continued functioning of the modified object
code is in no case prevented or interfered with solely because
modification has been made.
If you convey an object code work under this section in, or with, or
specifically for use in, a User Product, and the conveying occurs as
part of a transaction in which the right of possession and use of the
User Product is transferred to the recipient in perpetuity or for a
fixed term (regardless of how the transaction is characterized), the
Corresponding Source conveyed under this section must be accompanied
by the Installation Information. But this requirement does not apply
if neither you nor any third party retains the ability to install
modified object code on the User Product (for example, the work has
been installed in ROM).
The requirement to provide Installation Information does not include a
requirement to continue to provide support service, warranty, or updates
for a work that has been modified or installed by the recipient, or for
the User Product in which it has been modified or installed. Access to a
network may be denied when the modification itself materially and
adversely affects the operation of the network or violates the rules and
protocols for communication across the network.
Corresponding Source conveyed, and Installation Information provided,
in accord with this section must be in a format that is publicly
documented (and with an implementation available to the public in
source code form), and must require no special password or key for
unpacking, reading or copying.
7. Additional Terms.
"Additional permissions" are terms that supplement the terms of this
License by making exceptions from one or more of its conditions.
Additional permissions that are applicable to the entire Program shall
be treated as though they were included in this License, to the extent
that they are valid under applicable law. If additional permissions
apply only to part of the Program, that part may be used separately
under those permissions, but the entire Program remains governed by
this License without regard to the additional permissions.
When you convey a copy of a covered work, you may at your option
remove any additional permissions from that copy, or from any part of
it. (Additional permissions may be written to require their own
removal in certain cases when you modify the work.) You may place
additional permissions on material, added by you to a covered work,
for which you have or can give appropriate copyright permission.
Notwithstanding any other provision of this License, for material you
add to a covered work, you may (if authorized by the copyright holders of
that material) supplement the terms of this License with terms:
a) Disclaiming warranty or limiting liability differently from the
terms of sections 15 and 16 of this License; or
b) Requiring preservation of specified reasonable legal notices or
author attributions in that material or in the Appropriate Legal
Notices displayed by works containing it; or
c) Prohibiting misrepresentation of the origin of that material, or
requiring that modified versions of such material be marked in
reasonable ways as different from the original version; or
d) Limiting the use for publicity purposes of names of licensors or
authors of the material; or
e) Declining to grant rights under trademark law for use of some
trade names, trademarks, or service marks; or
f) Requiring indemnification of licensors and authors of that
material by anyone who conveys the material (or modified versions of
it) with contractual assumptions of liability to the recipient, for
any liability that these contractual assumptions directly impose on
those licensors and authors.
All other non-permissive additional terms are considered "further
restrictions" within the meaning of section 10. If the Program as you
received it, or any part of it, contains a notice stating that it is
governed by this License along with a term that is a further
restriction, you may remove that term. If a license document contains
a further restriction but permits relicensing or conveying under this
License, you may add to a covered work material governed by the terms
of that license document, provided that the further restriction does
not survive such relicensing or conveying.
If you add terms to a covered work in accord with this section, you
must place, in the relevant source files, a statement of the
additional terms that apply to those files, or a notice indicating
where to find the applicable terms.
Additional terms, permissive or non-permissive, may be stated in the
form of a separately written license, or stated as exceptions;
the above requirements apply either way.
8. Termination.
You may not propagate or modify a covered work except as expressly
provided under this License. Any attempt otherwise to propagate or
modify it is void, and will automatically terminate your rights under
this License (including any patent licenses granted under the third
paragraph of section 11).
However, if you cease all violation of this License, then your
license from a particular copyright holder is reinstated (a)
provisionally, unless and until the copyright holder explicitly and
finally terminates your license, and (b) permanently, if the copyright
holder fails to notify you of the violation by some reasonable means
prior to 60 days after the cessation.
Moreover, your license from a particular copyright holder is
reinstated permanently if the copyright holder notifies you of the
violation by some reasonable means, this is the first time you have
received notice of violation of this License (for any work) from that
copyright holder, and you cure the violation prior to 30 days after
your receipt of the notice.
Termination of your rights under this section does not terminate the
licenses of parties who have received copies or rights from you under
this License. If your rights have been terminated and not permanently
reinstated, you do not qualify to receive new licenses for the same
material under section 10.
9. Acceptance Not Required for Having Copies.
You are not required to accept this License in order to receive or
run a copy of the Program. Ancillary propagation of a covered work
occurring solely as a consequence of using peer-to-peer transmission
to receive a copy likewise does not require acceptance. However,
nothing other than this License grants you permission to propagate or
modify any covered work. These actions infringe copyright if you do
not accept this License. Therefore, by modifying or propagating a
covered work, you indicate your acceptance of this License to do so.
10. Automatic Licensing of Downstream Recipients.
Each time you convey a covered work, the recipient automatically
receives a license from the original licensors, to run, modify and
propagate that work, subject to this License. You are not responsible
for enforcing compliance by third parties with this License.
An "entity transaction" is a transaction transferring control of an
organization, or substantially all assets of one, or subdividing an
organization, or merging organizations. If propagation of a covered
work results from an entity transaction, each party to that
transaction who receives a copy of the work also receives whatever
licenses to the work the party's predecessor in interest had or could
give under the previous paragraph, plus a right to possession of the
Corresponding Source of the work from the predecessor in interest, if
the predecessor has it or can get it with reasonable efforts.
You may not impose any further restrictions on the exercise of the
rights granted or affirmed under this License. For example, you may
not impose a license fee, royalty, or other charge for exercise of
rights granted under this License, and you may not initiate litigation
(including a cross-claim or counterclaim in a lawsuit) alleging that
any patent claim is infringed by making, using, selling, offering for
sale, or importing the Program or any portion of it.
11. Patents.
A "contributor" is a copyright holder who authorizes use under this
License of the Program or a work on which the Program is based. The
work thus licensed is called the contributor's "contributor version".
A contributor's "essential patent claims" are all patent claims
owned or controlled by the contributor, whether already acquired or
hereafter acquired, that would be infringed by some manner, permitted
by this License, of making, using, or selling its contributor version,
but do not include claims that would be infringed only as a
consequence of further modification of the contributor version. For
purposes of this definition, "control" includes the right to grant
patent sublicenses in a manner consistent with the requirements of
this License.
Each contributor grants you a non-exclusive, worldwide, royalty-free
patent license under the contributor's essential patent claims, to
make, use, sell, offer for sale, import and otherwise run, modify and
propagate the contents of its contributor version.
In the following three paragraphs, a "patent license" is any express
agreement or commitment, however denominated, not to enforce a patent
(such as an express permission to practice a patent or covenant not to
sue for patent infringement). To "grant" such a patent license to a
party means to make such an agreement or commitment not to enforce a
patent against the party.
If you convey a covered work, knowingly relying on a patent license,
and the Corresponding Source of the work is not available for anyone
to copy, free of charge and under the terms of this License, through a
publicly available network server or other readily accessible means,
then you must either (1) cause the Corresponding Source to be so
available, or (2) arrange to deprive yourself of the benefit of the
patent license for this particular work, or (3) arrange, in a manner
consistent with the requirements of this License, to extend the patent
license to downstream recipients. "Knowingly relying" means you have
actual knowledge that, but for the patent license, your conveying the
covered work in a country, or your recipient's use of the covered work
in a country, would infringe one or more identifiable patents in that
country that you have reason to believe are valid.
If, pursuant to or in connection with a single transaction or
arrangement, you convey, or propagate by procuring conveyance of, a
covered work, and grant a patent license to some of the parties
receiving the covered work authorizing them to use, propagate, modify
or convey a specific copy of the covered work, then the patent license
you grant is automatically extended to all recipients of the covered
work and works based on it.
A patent license is "discriminatory" if it does not include within
the scope of its coverage, prohibits the exercise of, or is
conditioned on the non-exercise of one or more of the rights that are
specifically granted under this License. You may not convey a covered
work if you are a party to an arrangement with a third party that is
in the business of distributing software, under which you make payment
to the third party based on the extent of your activity of conveying
the work, and under which the third party grants, to any of the
parties who would receive the covered work from you, a discriminatory
patent license (a) in connection with copies of the covered work
conveyed by you (or copies made from those copies), or (b) primarily
for and in connection with specific products or compilations that
contain the covered work, unless you entered into that arrangement,
or that patent license was granted, prior to 28 March 2007.
Nothing in this License shall be construed as excluding or limiting
any implied license or other defenses to infringement that may
otherwise be available to you under applicable patent law.
12. No Surrender of Others' Freedom.
If conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot convey a
covered work so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you may
not convey it at all. For example, if you agree to terms that obligate you
to collect a royalty for further conveying from those to whom you convey
the Program, the only way you could satisfy both those terms and this
License would be to refrain entirely from conveying the Program.
13. Use with the GNU Affero General Public License.
Notwithstanding any other provision of this License, you have
permission to link or combine any covered work with a work licensed
under version 3 of the GNU Affero General Public License into a single
combined work, and to convey the resulting work. The terms of this
License will continue to apply to the part which is the covered work,
but the special requirements of the GNU Affero General Public License,
section 13, concerning interaction through a network will apply to the
combination as such.
14. Revised Versions of this License.
The Free Software Foundation may publish revised and/or new versions of
the GNU General Public License from time to time. Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.
Each version is given a distinguishing version number. If the
Program specifies that a certain numbered version of the GNU General
Public License "or any later version" applies to it, you have the
option of following the terms and conditions either of that numbered
version or of any later version published by the Free Software
Foundation. If the Program does not specify a version number of the
GNU General Public License, you may choose any version ever published
by the Free Software Foundation.
If the Program specifies that a proxy can decide which future
versions of the GNU General Public License can be used, that proxy's
public statement of acceptance of a version permanently authorizes you
to choose that version for the Program.
Later license versions may give you additional or different
permissions. However, no additional obligations are imposed on any
author or copyright holder as a result of your choosing to follow a
later version.
15. Disclaimer of Warranty.
THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY
APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT
HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY
OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,
THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM
IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF
ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
16. Limitation of Liability.
IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS
THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY
GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE
USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF
DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD
PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),
EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF
SUCH DAMAGES.
17. Interpretation of Sections 15 and 16.
If the disclaimer of warranty and limitation of liability provided
above cannot be given local legal effect according to their terms,
reviewing courts shall apply local law that most closely approximates
an absolute waiver of all civil liability in connection with the
Program, unless a warranty or assumption of liability accompanies a
copy of the Program in return for a fee.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.
To do so, attach the following notices to the program. It is safest
to attach them to the start of each source file to most effectively
state the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.
Copyright (C)
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see .
Also add information on how to contact you by electronic and paper mail.
If the program does terminal interaction, make it output a short
notice like this when it starts in an interactive mode:
Copyright (C)
This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License. Of course, your program's commands
might be different; for a GUI interface, you would use an "about box".
You should also get your employer (if you work as a programmer) or school,
if any, to sign a "copyright disclaimer" for the program, if necessary.
For more information on this, and how to apply and follow the GNU GPL, see
.
The GNU General Public License does not permit incorporating your program
into proprietary programs. If your program is a subroutine library, you
may consider it more useful to permit linking proprietary applications with
the library. If this is what you want to do, use the GNU Lesser General
Public License instead of this License. But first, please read
.
tuareg-3.0.1/HISTORY 0000664 0000000 0000000 00000013666 14315315656 0014113 0 ustar 00root root 0000000 0000000 Tuareg Mode is a thoroughly rewritten derivative of Caml Mode 0.9.x:
--------------------------------------------------------------------
First version -
By Xavier Leroy
and Jerome Vouillon , 1993.
Compilation interface -
By Ian Zimmerman , 1996;
Copyright (C) 1996 Ian Zimmerman, all rights reserved.
First Font-Lock and XEmacs support -
By Pierre Boulet , 1996.
First OCaml and OLabl version -
By Jacques Garrigue , 1996.
New version for OCaml (Objective Caml)
Extension to OCaml (and Labl) syntax (including literals
and preserving compatibility with Camllight syntax) complete
rewritting of Zimmerman's mode, especially comment detection
and indentation, along with major improvement of
indentation capabilities, new Font-Lock and
Hilit19, compatibility over Emacs and XEmacs;
By Albert Cohen , 1997.
Tuareg Mode history:
--------------------
1.00 - January 8 1997 -
First verion of Tuareg
(previously known as Caml-Mode 0.9.2 -> 0.9.8).
1.10 - From March 17 1997 to March 20 1997 -
to First release of Tuareg
1.12 Speed-up and fixes.
1.20 - From March 23 1997 to July 28 1997 -
to Support for symbol fontifying, adaptation of Font-Lock interface,
1.27 Rewritting of a new Sym-Lock extension for Font-Lock (more powerful,
polyvalent, and fitting dynamic customization). Suggestion and first
adaptation by Chrstian Boos .
Improved phrase detection. `C-M-h' and `C-c C-e' now detect
both beginning and end of phrases ; `;;' is used, if present.
Improved `tuareg-interactive' mode. Support for Font-Lock
on toplevel inputs. Patchs for many phrase detection bugs.
New option for `=' indentation, `match-string' optimized, and
indentation of `;' sequences accelerated.
1.30 - April 14 1998 -
Major improvement of syntax parsing code (including proper handling
of multi-line strings and speed-up). Strong speed-up of parenthesis
parsing. A few indentation and phrase-related commands bugs corrected.
1.31 - June 8 1998 -
Lot of bugs corrected, new customization (more flexible and usable,
with some examples). Minor Sym-Lock changes, indentation changes in
some cases, simplified installation guidelines.
1.32 - June 26 1998 -
Only with XEmacs: Correct string/comment hiliting.
A few bugs removed, especially in literal/comment detection.
New customization features.
1.33 - November 24 1998 -
New support for OCaml 2.00 syntax (let module X=..., and {r with ...}).
Indentation bug corrected for arrays, records and objects.
1.34 - December 15 1998 -
Bugs corrected in OCaml 2.00 syntax, added new indentation options
for parentheses and = symbols.
1.35 - January 13 1999 -
Major improvement of interactive mode, thanks to contribution
of Michel Quercia. Bug removal in phrase detection and comment
indentation (paragraph and lines).
1.36 - January 22 1999 -
Navigation support for OCaml manual, library, and buffer-dependent
definitions (adapted from original code by Michel Quercia). New
commands, and next-error in toplevel by Claude Marché.
1.37 - May 18 2000 -
Many improvements and extended support for OCaml 3.00 (like label
hiliting). Improved FSF Emacs compatibility thanks to Rémi Vanicat.
Corrected bugs in string/comment recognition (the last ones?).
1.38 - September 19 2000 -
Standard Customization interface, removal of most non-standard
font-lock faces, string/comment hiliting for FSF Emacs
eventually matches XEmacs performances; plus a lot of minor fixes.
1.40 - June 26 2002 -
Major update: FSF Emacs 21 compatibility (lazy Font-Lock support),
new indentation features (e.g., smart comment justification styles),
robust hiliting for declarations, many bugs corrected.
1.41 - December 8 2003 -
Indentation and hiliting features, many intermediate versions
with minor bug fixes, support for caml-types.
1.42 - November 5 2004 -
MetaOCaml support, many bug fixes, major rewrite of hiliting code,
many improvements and bug fixes to the indentation code,
refactoring of some deprecated code (by Stefan Monnier).
1.43 - November 21 2004 -
Improved MetaOCaml support, phrase mark/evaluation fixes,
many improvements to module indentation and marking, removed
aggresive inlining after `=' and fixed related bugs.
1.44 - December 29 2004 -
Major fontification improvements, largely by Stefan Monnier.
Many bug fixes related with the improvements in 1.42 and 1.43.
1.45 - March 28 2005 -
New symbol fontification, compatible with FSF Emacs, by
Stefan Monnier. Initiation of a migration of the syntax cache to
PPSS for comments and string.
1.46 - May 21 2006 -
Integration of more language variants. A future version will
modularize this support, to improve flexibility and minimize
interference risks. Plus various bug fixes and new features.
1.46 - February 2010 - November 2010 -
to Changes by Jane Street Capital, Sam setingold and Christophe
2.04 Troestler. The log of Sam's changes is written below.
2.05 -
Cleanup; removal of ocamlspot.el (bundled with ocamlspot).
Changes made by Sam Steingold
* 2010-02-09
== Many indentation fixes.
== Code cleaned up and updated to the modern Emacs Lisp;
compilation warnings eliminated.
* 2010-03-10
== Treat ">>>" just like ">>=" for indentation purposes.
== `Jane style' indentation of `type' statements now requires
`tuareg-type-indent'=0.
== `until' & `unless' are only special in ls3, not general ocaml.
== Other indentation fixes.
* 2010-04-20 (1.99.2)
== Many indentation fixes.
== Better regression testing.
== Restore reasonable behavior without Jane custom settings.
* 2010-05-03 (2.0)
== Many indentation fixes.
== Prepare the first official release from Jane Street.
tuareg-3.0.1/Makefile 0000664 0000000 0000000 00000007475 14315315656 0014470 0 ustar 00root root 0000000 0000000 VERSION = $(shell grep ';; Version:' tuareg.el \
| sed 's/;; Version: *\([0-9.]*\).*/\1/')
DESCRIPTION = $(shell grep ';;; tuareg.el ---' tuareg.el \
| sed 's/[^-]*--- *\([^.]*\).*/\1/')
REQUIREMENTS = $(shell grep ';; Package-Requires:' tuareg.el \
| sed 's/;; Package-Requires: *\(.*\)/\1/')
DIST_NAME = tuareg-$(VERSION)
TARBALL = $(DIST_NAME).tar.gz
OPAM_FILE = packages/tuareg/tuareg.$(VERSION)/opam
SOURCES = tuareg.el ocamldebug.el tuareg-opam.el \
tuareg-menhir.el tuareg-compat.el
ELS = $(SOURCES) tuareg-site-file.el
ELC = $(ELS:.el=.elc)
INSTALL_FILES = $(ELS) $(ELC)
INSTALL_DIR ?= $(shell opam var share)/emacs/site-lisp
DIST_FILES += $(ELS) Makefile README.md tuareg.install
EMACSFORMACOSX = /Applications/Emacs.app/Contents/MacOS/Emacs
EMACSMACPORTS = /Applications/MacPorts/Emacs.app/Contents/MacOS/Emacs
AQUAMACS = /Applications/Aquamacs.app/Contents/MacOS/Aquamacs
ifeq ($(wildcard $(EMACSFORMACOSX)),$(EMACSFORMACOSX))
EMACS ?= $(EMACSFORMACOSX)
else
ifeq ($(wildcard $(EMACSMACPORTS)),$(EMACSMACPORTS))
EMACS ?= $(EMACSMACPORTS)
else
ifeq ($(wildcard $(AQUAMACS)),$(AQUAMACS))
EMACS ?= $(AQUAMACS)
endif
endif
endif
EMACS ?= emacs
RM ?= rm -f
CP ?= cp -f
LN = ln
DIFF = diff -u -B
INSTALL_RM_R = $(RM) -r
INSTALL_MKDIR = mkdir -p
INSTALL_CP = cp
all elc : $(ELC) tuareg-site-file.el
elc-werror: WERROR=--eval '(setq byte-compile-error-on-warn t)'
elc-werror: elc
%.elc : %.el
$(EMACS) --batch -L . --no-init-file $(WERROR) -f batch-byte-compile $<
install : $(INSTALL_FILES)
$(INSTALL_MKDIR) $(INSTALL_DIR)
$(INSTALL_CP) $(INSTALL_FILES) $(INSTALL_DIR)/
$(POST_INSTALL_HOOK)
uninstall :
-test -d $(INSTALL_DIR) && \
$(INSTALL_RM_R) $(addprefix $(INSTALL_DIR)/, $(INSTALL_FILES))
.PHONY: refresh
refresh:
.PHONY: check
check:
$(EMACS) -batch -Q -L . -l tuareg-tests -f ert-run-tests-batch-and-exit
%.test: % $(ELC) refresh
@echo ====Indent $*====
-$(RM) $@
$(EMACS) --batch -q --no-site-file $(ENABLE_SMIE) \
--load tuareg-site-file.el $< \
--eval '(setq indent-tabs-mode nil)' \
--eval '(defun ask-user-about-lock (file opponent) nil)' \
--eval '(indent-region (point-min) (point-max) nil)' \
--eval '(indent-region (point-min) (point-max) nil)' \
--eval '(write-region (point-min) (point-max) "$@")'
$(DIFF) $< $@ || true
indent-test: indent-test.ml.test
tuareg-site-file.el: $(SOURCES)
(echo ";;; $@ --- Automatically extracted autoloads. -*- lexical-binding: t; -*-";\
echo ";;; Code:";\
echo "(add-to-list 'load-path";\
echo " (or (file-name-directory load-file-name) (car load-path)))";\
echo " ") >$@
$(EMACS) --batch --eval '(if (>= emacs-major-version 28) (make-directory-autoloads "." "'`pwd`'/$@") (setq generated-autoload-file "'`pwd`'/$@") (batch-update-autoloads))' "."
tuareg.install:
echo "share_root: [" > $@
for f in $(ELS); do \
echo " \"$$f\" {\"emacs/site-lisp/$$f\"}" >> $@; \
echo " \"?$${f}c\" {\"emacs/site-lisp/$${f}c\"}" >> $@; \
done
echo "]" >> $@
dist distrib: $(TARBALL)
$(TARBALL): $(DIST_FILES)
mkdir -p $(DIST_NAME)
for f in $(DIST_FILES); do $(LN) $$f $(DIST_NAME); done
echo '(define-package "tuareg" "$(VERSION)" "$(DESCRIPTION)" ' "'"'$(REQUIREMENTS))' > $(DIST_NAME)/tuareg-pkg.el
tar acvf $@ $(DIST_NAME)
$(RM) -r $(DIST_NAME)
submit: $(TARBALL)
@if [ ! -d packages/ ]; then \
echo "Make a symbolic link packages → OPAM repository/packages"; \
exit 1; \
fi
$(INSTALL_MKDIR) $(dir $(OPAM_FILE))
$(CP) -a tuareg.opam $(OPAM_FILE)
echo "url {" >> $(OPAM_FILE)
echo " src: \"https://github.com/ocaml/tuareg/releases/download/$(VERSION)/$(TARBALL)\"" >> $(OPAM_FILE)
echo " checksum: \"`md5sum $(TARBALL) | cut -d ' ' -f 1`\"" \
>> $(OPAM_FILE)
echo "}" >> $(OPAM_FILE)
clean :
$(RM) $(ELC) "$(DIST_NAME).tar.gz" "$(DIST_NAME).tar"
$(RM) -r tuareg.$(VERSION)
.PHONY : all elc clean install uninstall check distrib dist submit
tuareg-3.0.1/README.md 0000664 0000000 0000000 00000026200 14315315656 0014272 0 ustar 00root root 0000000 0000000 [](https://elpa.nongnu.org/nongnu/tuareg.html)
[](https://melpa.org/#/tuareg)
[](https://packages.debian.org/stable/elpa-tuareg)
[](COPYING)
[](https://github.com/ocaml/tuareg/actions?query=workflow%3Atest)
Tuareg: an Emacs OCaml mode
===========================
This archive contains files to help editing [OCaml](http://ocaml.org/)
code, to highlight important parts of the code, to run an OCaml
[REPL](https://en.wikipedia.org/wiki/Read%E2%80%93eval%E2%80%93print_loop)
(also called *toplevel*),
and to run the OCaml debugger within Emacs.
Package Contents
--------
- `README.md` — This file.
- `HISTORY` — Differences with previous versions.
- `tuareg.el` — A major mode for editing OCaml code in Emacs.
- `ocamldebug.el` — To run the OCaml debugger under Emacs.
- `sample.ml` — Sample file to check the indentation engine.
- `compilation.txt` — To check the compilation regexp `tuareg--error-regexp`.
Install
-------
The easier way to install Tuareg is though
the [Emacs package system](https://www.gnu.org/software/emacs/manual/html_node/emacs/Packages.html)
with [NonGNU ELPA][] or
[MELPA][] ([configuration](https://melpa.org/#/getting-started)).
You can also install it using [OPAM][]:
opam install tuareg
and follow the instructions given at the end of the `opam`
installation.
If you want to install from the Git checkout, just add to your
[Init File][] the line:
(load "path-to-git-checkout-dir/tuareg-site-file")
If you want to byte compile the files, issue `make elc`. If you do
this in Darwin, make sure that the version of Emacs displayed at the
end of `make elc` is the sole that you use (the `.elc` files may not
be compatible with other versions of Emacs installed on your system).
Usage & Configuration
---------------------
The Tuareg major mode is triggered by visiting a file with extension
`.ml`, `.mli`, and `.mlp` or manually by M-x tuareg-mode.
A [Menhir][] mode, `tuareg-menhir`, supports `.mly` files. (A special
mode for `.mll` has yet to be written.)
For the convenience of users of [ocsigen][], the extensions
[`.eliom`](http://ocsigen.org/eliom/), `.eliomi` trigger `tuareg-mode`.
Start the OCaml REPL with M-x run-ocaml.
To evaluate a
phrase, simply type S-⟨return⟩ (shift and
return). You can also evaluate a
phrase in a different buffer by typing C-c C-e when the
cursor is on it (it
will start the OCaml REPL if needed).
Run the OCaml debugger with M-x ocamldebug FILE.
Tips & customization
--------------------
- You can comment/uncomment a single line with `tuareg-comment-dwim`
which is bound to C-cC-;.
- By default, Tuareg will align the arguments of functions as follows:
function_name arg1
arg2
This is what most OCaml programmers expect and is convenient if you
use the following style:
function_name (fun x ->
do_something
)
arg2
If you prefer the “lisp style” indentation in which arguments on the
second line are aligned with the arguments on the first line as in
function_name arg1
arg2
put `(setq tuareg-indent-align-with-first-arg t)` in your [Init File][].
In both cases, if there are no argument on the line following the
function name, the indentation will be:
function_name
arg1
arg2
- To make easier to distinguish pattern-match cases containing several
patterns, sub-patterns are slightly indented as in
match x with
| A
| B -> ...
| C -> ...
If you prefer all pipes to be aligned as
match x with
| A
| B -> ...
| C -> ...
use `(setq tuareg-match-patterns-aligned t)`.
- Emacs ≥ 24.4 turned on [electric-indent-mode][] mode by default. If
you do not like it, call `(electric-indent-mode 0)` in
`tuareg-mode-hook`.
[electric-indent-mode]: https://www.gnu.org/software/emacs/manual/html_node/emacs/Indent-Convenience.html
- Tuareg respects you default commenting style. However, in OCaml,
commenting a region is usually done with a single multi-line comment
and without leading stars on each line. You can have that behavior
in OCaml buffers by setting:
(add-hook 'tuareg-mode-hook
(lambda()
(setq-local comment-style 'multi-line)
(setq-local comment-continue " ")))
- If you turn on `show-paren-mode`, the delimiters of comments will
also be highlighted. If you do not like this behavior, set
`tuareg-comment-show-paren` to `nil`.
- Syntax highlighting has 3 levels. You can select the one you prefer
by setting [font-lock-maximum-decoration][] from `0` to `2`. By
default, [font-lock-maximum-decoration][] is set to `t` which
means that the maximum level of decoration will be used.
[font-lock-maximum-decoration]: https://www.gnu.org/software/emacs/manual/html_node/emacs/Font-Lock.html
- Fontifying all operators (as opposed to only non-standard ones) is a
costly operation that slows down font-lock. This is why it is
disabled by default. If you nonetheless want it, set
`tuareg-highlight-all-operators` to `t` in your [Init File][]
(before `tuareg-mode` is initialized; in particular, not in a hook
added to `'tuareg-mode-hook`).
- You can turn on and off the rendering of certain sequences of
characters as symbols (such as `∔` and `∧` instead of `+.`and `&&`),
use `prettify-symbols-mode` or use the check box in the _Tuareg
Options_ menu. To enable it by default when you start Tuareg, add
the following to your [Init File][]:
(add-hook 'tuareg-mode-hook
(lambda()
(when (functionp 'prettify-symbols-mode)
(prettify-symbols-mode))))
If you want more symbols to be prettified (such as `->` being
displayed as `→`) at the expense of modifying the indentation in
incompatible ways with those not using that option, add `(setq
tuareg-prettify-symbols-full t)` to your [Init File][].
- By default, constructors are highlighted with the default face
because having too many colors is distracting. If you wish to
customize the appearance of constructors, add to your [Init File][]
the following code adapted to your tastes.
(face-spec-set
'tuareg-font-lock-constructor-face
'((((class color) (background light)) (:foreground "SaddleBrown"))
(((class color) (background dark)) (:foreground "burlywood1"))))
- To have a list of definitions in the buffer, use [imenu][]. It is
available by right clicking in the buffer. You can also launch the
`speedbar` and click on file to have a list of definitions.
[imenu]: https://www.gnu.org/software/emacs/manual/html_node/emacs/Imenu.html
- If you wish to have a nice 🐫 as the mode name, add
(add-hook 'tuareg-mode-hook
(lambda() (setq tuareg-mode-name "🐫")))
to your [Init File][].
Thanks to the work of Stefan Monnier, a new indentation engine based on
[SMIE](https://www.gnu.org/software/emacs/manual/html_node/elisp/SMIE.html)
was written. This changes the indentation somewhat w.r.t. the
previous versions of `tuareg`. If the indentation does not correspond
to what you expect, please submit a
[motivated issue](https://github.com/ocaml/tuareg/issues/).
The standard Emacs customization tool can be used to configure Tuareg
options. It is available from the Options menu and Tuareg's Customize
sub-menu. Note that, at the moment, both customization options
pertaining to the SMIE indentation mode and the old one are present.
You may also customize the appearance of OCaml code by twiddling the
variables listed at the start of tuareg.el (preferably using
`tuareg-mode-hook`, you should not patch the file directly).
You should then add to your configuration file something like:
(add-hook 'tuareg-mode-hook
(lambda () ... ; your customization code ))
For example:
(add-hook 'tuareg-mode-hook
;; Turn on auto-fill minor mode.
#'auto-fill-mode)
See [dot-emacs.el](dot-emacs.el) for some examples.
[Init File]: https://www.gnu.org/software/emacs/manual/html_node/emacs/Init-File.html
Additional packages
-------------------
### Merlin
It is recommended to install [Merlin][] which is available in
[OPAM][]. Tuareg will automatically detect it and use some of its
features (e.g. for *imenu*). Merlin offers auto-completion, the
possibility to query the type with C-cC-t, to find the
location of an identifier with C-cC-l, to go to the next
(resp. previous) phrase with C-cC-n
(resp. C-cC-p),... Highly recommended.
### Caml mode
[caml-mode][] (available in [NonGNU ELPA][] and [MELPA][]) is used to
display types (using
the obsolete `*.annot` files), open a module for documentation,...
[Menhir]: http://gallium.inria.fr/~fpottier/menhir/
[ocsigen]: http://ocsigen.org/
[Merlin]: https://github.com/ocaml/merlin
[OPAM]: http://opam.ocaml.org/
[caml-mode]: https://github.com/ocaml/caml-mode
[NonGNU ELPA]: https://elpa.nongnu.org/
[MELPA]: https://melpa.org/
Reporting
---------
The official Tuareg home page is located at:
.
Bug reports & patches: use the tracker:
.
Thanks
------
Ian Zimmerman for the previous mode, compilation interface and
debugger enhancement.
Jacques Garrigue enhanced Zimmerman's mode along with an adaptation
to OCaml (and Labl) syntax. Although this work was performed
independently, his useful test file and comments were of great help.
Michel Quercia for excellent suggestions, patches, and helpful
emacs-lisp contributions (full, ready-to-work implementations, I
should say), especially for Tuareg interactive mode, and browser
capacities.
Denis Barthou, Pierre Boulet, Jean-Christophe Filliatre and Rémi
Vanicat for intensive testing, useful suggestions, and help.
Ralf Treinen for maintaining the Debian GNU/Linux package.
Every people who sent me bug reports, suggestions, comments and
patches. Nothing would have improved since version 0.9.2 without
their help. Special thanks to Eli Barzilay, Josh Berdine, Christian
Boos, Carsten Clasohm, Yann Coscoy, Prakash Countcham, Alvarado
Cuihtlauac, Erwan David, Gilles Défourneaux, Philippe Esperet,
Gilles Falcon, Tim Freeman, Alain Frisch, Christian Lindig, Claude
Marché, Charles Martin, Dave Mason, Stefan Monnier, Toby Moth,
Jean-Yves Moyen, Alex Ott, Christopher Quinn, Ohad Rodeh, Rauli
Ruohonen, Hendrik Tews, Christophe Troestler, Joseph Sudish, Mattias
Waldau and John Whitley.
Tuareg mode have been maintained by Albert Cohen until version 1.45.
Jane Street took over maintenance based on Albert Cohen's version 1.46
(later retracted by him), and released its first version as 2.0.
License
-------
Tuareg is distributed under the GNU General Public License, version 3 or later.
tuareg-3.0.1/compilation.txt 0000664 0000000 0000000 00000013222 14315315656 0016072 0 ustar 00root root 0000000 0000000 OCaml Error Messages -*-compilation-*-
Shows different OCaml error messages and how they are rendered.
File "file.ml", line 4, characters 6-7:
Error: This expression has type int
This is not a function; it cannot be applied.
File "file.ml", line 3, characters 6-7:
Warning 26: unused variable y.
File "file.ml", line 6, characters 15-38:
Error: Signature mismatch:
Modules do not match: sig val x : float end is not included in X
Values do not match: val x : float is not included in val x : int
File "file.ml", line 3, characters 2-13: Expected declaration
File "file.ml", line 7, characters 6-7: Actual declaration
File "file.ml", line 8, characters 6-7:
Warning 32: unused value y.
* Since OCaml 4.08, the error messages have the following form.
File "helloworld.ml", line 2, characters 36-64:
2 | module rec A: sig type t += A end = struct type t += A = B.A end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Cannot safely evaluate the definition of the following cycle
of recursively-defined modules: A -> B -> A.
There are no safe modules in this cycle (see manual section 8.2).
File "helloworld.ml", lines 4-7, characters 6-3:
4 | ......struct
5 | module F(X:sig end) = struct end
6 | let f () = B.value
7 | end
Error: Cannot safely evaluate the definition of the following cycle
of recursively-defined modules: A -> B -> A.
There are no safe modules in this cycle (see manual section 8.2).
File "robustmatch.ml", lines 33-37, characters 6-23:
9 | ......match t1, t2, x with
10 | | AB, AB, A -> ()
11 | | MAB, _, A -> ()
12 | | _, AB, B -> ()
13 | | _, MAB, B -> ()
Warning 8: this pattern-matching is not exhaustive.
Here is an example of a case that is not matched:
(AB, MAB, A)
File "helloworld.ml", line 2, characters 36-64:
Error: Cannot safely evaluate the definition of the following cycle
of recursively-defined modules: A -> B -> A.
There are no safe modules in this cycle (see manual section 8.2).
File "helloworld.ml", line 2, characters 36-64:
Warning 3: Cannot safely evaluate the definition of the following cycle
of recursively-defined modules: A -> B -> A.
There are no safe modules in this cycle (see manual section 8.2).
File "helloworld.ml", line 2, characters 36-64:
2 | module rec A: sig type t += A end = struct type t += A = B.A end
^^^^^^^^^^^^^^^^^^^^^^^^
Warning: Cannot safely evaluate the definition of the following cycle
of recursively-defined modules: A -> B -> A.
There are no safe modules in this cycle (see manual section 8.2).
File "main.ml", line 3, characters 8-50:
Error: This expression has type float but an expression was expected of type
int
File "main.ml", line 3, characters 8-50:
Warning 3: This expression has type float but an expression was expected of type
int
File "main.ml", line 13, characters 34-35:
13 | let f : M.t -> M.t = fun M.C -> y
^
Error: This expression has type M/2.t but an expression was expected of type
M/1.t
File "main.ml", line 10, characters 2-41:
Definition of module M/1
File "main.ml", line 7, characters 0-32:
Definition of module M/2
File "main.ml", line 13, characters 34-35:
13 | let f : M.t -> M.t = fun M.C -> y
^
Error: This expression has type M/2.t but an expression was expected of type
M/1.t
File "main.ml", line 10, characters 2-41:
Definition of module M/1
File "main.ml", line 7, characters 0-32:
Definition of module M/2
* Since OCaml 4.12, warnings come with mnemonics.
File "moo.ml", line 6, characters 6-10:
6 | let fish = 13 in
^^^^
Warning 26 [unused-var]: unused variable fish.
* Example of a warning with ancillary locations
File "urk.ml", line 1:
Warning 63 [erroneous-printed-signature]: The printed interface differs from the inferred interface.
The inferred interface contained items which could not be printed
properly due to name collisions between identifiers.
File "urk.ml", lines 23-25, characters 2-5:
Definition of module M/1
File "urk.ml", lines 17-20, characters 0-3:
Definition of module M/2
Beware that this warning is purely informational and will not catch
all instances of erroneous printed interface.
module M : sig type t val v : t end
module F : sig module M : sig val v : M.t end val v : M/2.t end
* Alert: treat like warning
File "alrt.ml", line 25, characters 9-10:
25 | val x: t [@@ocaml.deprecated]
^
Alert deprecated: t
* Backtrace messages
Before 4.11:
OCAMLRUNPARAM=b ./bad
Fatal error: exception Bad.Disaster("oh no!")
Raised at file "bad.ml", line 5, characters 4-22
Called from file "bad.ml" (inlined), line 9, characters 2-5
Called from file "bad.ml", line 12, characters 8-18
4.11 and later:
OCAMLRUNPARAM=b ./bad
Fatal error: exception Bad.Disaster("oh no!")
Raised at Bad.f in file "bad.ml", line 5, characters 4-22
Called from Bad.g in file "bad.ml" (inlined), line 9, characters 2-5
Called from Bad in file "bad.ml", line 12, characters 8-18
OCAMLRUNPARAM=b ./bad
Fatal error: exception Sys_error("non.existing.file: No such file or directory")
Raised by primitive operation at Stdlib.open_in_gen in file "stdlib.ml", line 399, characters 28-54
Called from Bad.h in file "bad.ml", line 7, characters 13-40
Called from Bad.f in file "bad.ml", line 13, characters 4-7
Re-raised at Bad.f in file "bad.ml", line 14, characters 12-19
Called from Bad.g in file "bad.ml", line 17, characters 2-5
Called from Bad in file "bad.ml", line 20, characters 8-18
tuareg-3.0.1/dot-emacs.el 0000664 0000000 0000000 00000002571 14315315656 0015216 0 ustar 00root root 0000000 0000000 ;; -*- lexical-binding: t; -*-
(require 'tuareg)
;; See README
(setq tuareg-indent-align-with-first-arg nil)
(add-hook
'tuareg-mode-hook
(lambda()
(setq show-trailing-whitespace t)
(setq indicate-empty-lines t)
;; Enable the representation of some keywords using fonts
(when (functionp 'prettify-symbols-mode)
(prettify-symbols-mode))
(when (functionp 'flyspell-prog-mode)
(flyspell-prog-mode))
;; See README
;;(setq tuareg-match-patterns-aligned t)
;;(electric-indent-mode 0)
))
;; Easy keys to navigate errors after compilation:
(define-key tuareg-mode-map [(f12)] #'next-error)
(define-key tuareg-mode-map [(shift f12)] #'previous-error)
;; Use Merlin if available
(when (require 'merlin nil t)
(setq merlin-command 'opam)
(add-to-list 'auto-mode-alist '("/\\.merlin\\'" . conf-mode))
(when (functionp 'merlin-document)
(define-key tuareg-mode-map (kbd "\C-c\C-h") #'merlin-document))
;; Run Merlin if a .merlin file in the parent dirs is detected
(add-hook 'tuareg-mode-hook
(lambda()
(let ((fn (buffer-file-name)))
(if (and fn (locate-dominating-file fn ".merlin"))
(merlin-mode))))))
;; Choose modes for related config. files
(setq auto-mode-alist
(append '(("_oasis\\'" . conf-mode)
("_tags\\'" . conf-mode)
("_log\\'" . conf-mode))
auto-mode-alist))
tuareg-3.0.1/indent-test-failed.ml 0000664 0000000 0000000 00000011447 14315315656 0017034 0 ustar 00root root 0000000 0000000 (* This fail contains code samples that are currently not indented
properly.
As indentation bugs are fixed, the corresponding samples should
be moved to the file indent-test.ml. *)
let quux list = List.map list ~f:(fun item ->
print_item item
)
let h x =
try ff a b
c d;
gg 1 2
3 4;
with e -> raise e
let x = foo ~f:(fun _ -> 0 (* Comment. *)
)
let () =
foo (sprintf ("a: %s"
^ " b: %s")
a
b)
let () =
Hashtbl.iter times ~f:(fun ~key:time ~data:azot ->
Clock.at time
>>> fun () ->
Db.iter t.db ~f:(fun dbo ->
if S.mem azot (Dbo.azo dbo) then
Dbo.dont dbo))
let w f =
List.map f ~f:(fun (a, b) ->
L.r a
>>= function
| Ok s -> `Fst (b, s)
| Error e -> `Snd (b, a, e))
let a =
B.c d ~e:f [
"g";
"h";
]
let a =
foo
~f:(fun () -> a
)
let () =
(* Comment. *)
bar a b
c d;
foo ~size
(* Comment. *)
~min:foo
?reduce
?override
()
let foo =
(* Comment. *)
List.map z
~f:(fun m ->
M.q m
|! T.u ~pr ~verbose:false
~p:H.P.US ~is_bar:false)
|! List.sort ~cmp:(fun a b ->
compare
(I.r a.T.s)
(I.r b.T.s))
let () =
snoo ~f:(fun foo ->
foo = bar
&& snoo)
let () =
snoo ~f:(fun foo ->
foo + bar
&& snoo)
let () =
snoo ~f:(fun foo ->
foo
&& snoo)
let variants a =
match String.split a ~on:'-' with
| [ s1; s2; s3 ] ->
let a0 = String.concat ~sep:"" [ s1; s2] in
let a1 = String.concat ~sep:"-" [ s1; s2; s3; "055" ] in (* Comment. *)
List.map [ a0; a1; a]
~f:(fun a_s -> lookup a_s)
|! List.flatten
| _ -> failwith "bad"
let optional_sci_float =
do_something ~a:1e-7
~b:(fun x -> x + 1)
let array_args =
fold s multi_sms.(0).message_number folder
more_args (* FIXME *)
let () =
match var with
| <:expr< $lid:f$ >> ->
KO
| <:expr< $lid:f$ >> when f x ->
KO
| y when f y ->
OK
| long_pattern
when f long_pattern -> (* Should be more indented than the clause body *)
z
let subscribe_impl dir topic ~aborted =
return (
match Directory.subscribe dir topic with
| None -> Error ()
| Some pipe ->
whenever (aborted >>| fun () -> Pipe.close_read pipe);
Ok pipe
)
next_argument (* should be indented correctly, given the braces *)
let command =
Command.Spec.(
empty
+> flag "-hello" (optional_with_default "Hello" string)
~doc:" The 'hello' of 'hello world'"
+> flag "-world" (optional_with_default "World" string)
~doc:" The 'world' of 'hello world'"
)
let server_comments request t =
t >>= Grep.server_comments
lazy
parser
every
let x = match y, z with
| A, (B | C)
| X, Y -> do_something() (* Issue #78 *)
type t = a
and typey = 4
and x = b
type 'a v = id:O.t ->
ssss:Ssss.t ->
dddd:ddd.t ->
t:S_m.t ->
mmm:Safe_float.t ->
qqq:int ->
c:C.t ->
uuuu:string option ->
aaaaaa:Aaaaaa.t ->
a:A.t ->
rrrrr:Rrrrr.t ->
time:Time.t ->
typ:[ `L_p of Safe_float.t ] ->
bazonk:present option ->
o_p_e:O_m.t option ->
only_hjkl:present option ->
show_junk:int option ->
d_p_o: Safe_float.t option ->
asdf:present option ->
generic:Sexp.t list ->
'a
let () =
try f a
with A () ->
()
| B () ->
()
| C () ->
()
let () =
match _ with
| foo ->
bar
>>| function _ ->
_
let foo x =
f1 x >= f2 x
&& f3
(f4 x)
let foo x =
(>=)
(f1 x) (f2 x)
&& f3
(f4 x)
let splitting_long_expression =
quad.{band, i3} <- quad.{band, i3} +. g +.
area_12 *. (P.potential x13 y13 +. P.potential x23 y23)
let x =
try a
with Not_found ->
b
| _ ->
c
let x =
try a
with Not_found ->
if a then b
| flag when String.is_prefix flag ~prefix:"-" ->
a
| _ ->
c
let () =
match var with
| <:expr< $lid:f$ >> ->
KO
| <:expr< $lid:f$ >> when f x ->
KO
| y when f y ->
OK
| long_pattern
when f long_pattern -> (* Should be more indented than the clause body *)
z
let _ =
List.map
(function x ->
blabla (* FIXME: indentation afer "(function" *)
blabla
blabla)
l
tuareg-3.0.1/indent-test.ml 0000664 0000000 0000000 00000053162 14315315656 0015612 0 ustar 00root root 0000000 0000000 (* indent-test.ml --- Sample file for regression testing. -*- mode: tuareg; indent-tabs-mode:nil -*-
*
* The code in here has the following property:
* - the indentation is acceptable (maybe not perfect for everyone,
* but at least correct for some users).
* - the indentation code does find this indentation.
* This file is used for regression testing in tuareg-tests.el.
*
* This is in contrast to indent-test-failed.ml which contains indentation
* layouts which the indentation code doesn't know how to find.
*)
let server_comments request t =
let module M = N in
let class M = N in
let m M = N in
let module M = N in
let open Grep.Server in
let x = 5 in
let () =
a;%ext (* bug:121 *)
b in
let modue x y = 5 in
let open M in
t >>= Grep.server_comments
lazy
parser
every
module Make_comp(C : Comparitor) : Comparitor_intf (* issue #7 *)
with type t := C.t
and module X = Z =
struct
type t = C.t
let ret = C.comp
end
type 'a foo = 'a option = (* Issue #98 *)
| None
| Some of 'a
let qs1 = {| quoted string |} (* (issue #24) *)
let qs2 = {eof| other quoted string |noteof} |eof}
(* ocp-indent does it as follows:
let test1 = with_connection (fun conn ->
␣␣␣␣do_something conn x;
␣␣␣␣...
␣␣)
␣␣␣␣toto
(space written as ␣ to avoid reindent smashing this comment)
*)
let test1 = with_connection (fun conn ->
do_something conn x;
...
)
toto
let x = match y with (* Issue #71 *)
| A | B | C ->
do_something ()
let x =
begin match y with
| A -> 1 (* Issue #73 *)
end
let command = (* Issue #130 *)
match x with
A ->
a
| B ->
b
let x =
let open M in
let x = 5 in
x + x
;;
let () =
let z = function t -> a in
foo z
let () =
foo(function t -> a)
;;
let () =
begin
(begin
end)
end
;;
;; (* http://caml.inria.fr/mantis/view.php?id=4247 *)
let x = {
Foo.
a = b;
c = d;
e = {Bar.
f = 1;
g = 2;
};
h = { Quux.
i = 3;
j = 4;
};
}
;; (* http://caml.inria.fr/mantis/view.php?id=4249 *)
let x = { a = b;
c = d;
}
;; (* http://caml.inria.fr/mantis/view.php?id=4255 (¡seems unrelated!) *)
let x = { foo: [ `Foo of int
| `Bar of string ];
}
let s = { a with
b = 1;
}
;;
let a = {
M.
foo = foo;
bar = bar;
}
let a = { t with M.
foo = foo;
bar = bar;
}
let a = { t with
M.
foo = foo;
bar = bar;
}
type t = [ `Foo of int
| `Bar of string ]
type t =
| A
| B (* issue #76 *)
| C
with sexp
type t =
A
| B
| C
with sexp
type t = | A
| B
| C
type t = [
| `A
| `B
| `C
]
type t = [ (* Comment. *)
| `A
| `B
| `C
]
type t = a
and typey = 4
and x = b
type t =
| A
and u =
| B
type _ gadt =
| A : int -> int gadt
| B : unit gadt
| C : float -> float gadt
module M = struct
type t =
| A
| B
| C
with sexp
type s = [
| `A
| `B
| `C
]
type u =
| D
| E
with sexp
end
module N =
struct
type u =
| D
| E
with sexp
end
type m =
| T
with sexp
;; (* http://caml.inria.fr/mantis/view.php?id=4334 *)
type foo =
a
-> b
-> c
-> d
val f :
a:a
-> b:b
-> c:c
type bar = a -> b
-> c -> d
-> e -> f
type baz = a -> b ->
c -> d ->
e -> f
val quux : a -> b ->
c -> d ->
e -> f
type t : a:b -> c:d
-> e:f -> g
val f : a:b -> c:d
-> e:f -> g
type t = {
foo : (a
-> b
-> c
-> d);
}
type t = {
foo : ( a ->
b ->
c ->
d);
}
type t = {
foo : a
-> b
-> c
-> d;
bar :
a
-> b
-> c;
}
type t = {
foo : a ->
b ->
c ->
d;
bar :
a ->
b ->
c;
}
type t = {
a : B.t;
c : D.t;
e : F.t;
g : H.t I.t;
j :
K.t L.t;
m : N.t O.t;
p :
((q:R.t
-> s:T.U.t
-> v:(W.t -> X.t option)
-> y:(Z.t -> A.t -> B.t C.D.t E.t)
-> f:(G.t -> H.t I.t option)
-> j:(K.t -> L.t M.t option)
-> n:(O.t -> p option)
-> q:R.t
-> s:(string -> unit) -> T.t
)
-> U.t
-> V.W.t
-> X.t);
y : Z.t A.t;
b : C.t D.t E.t;
f : (G.t -> H.t -> I.t J.t);
} with sexp_of
(* FIXME: If you use `prettify-symbols-mode, the indentation changes :-( *)
type 'a v = id:O.t ->
ssss:Ssss.t ->
dddd:ddd.t ->
t:S_m.t ->
mmm:Safe_float.t ->
qqq:int ->
c:C.t ->
uuuu:string option ->
aaaaaa:Aaaaaa.t ->
a:A.t ->
rrrrr:Rrrrr.t ->
time:Time.t ->
typ:[ `L_p of Safe_float.t ] ->
bazonk:present option ->
o_p_e:O_m.t option ->
only_hjkl:present option ->
show_junk:int option ->
d_p_o: Safe_float.t option ->
asdf:present option ->
generic:Sexp.t list ->
'a
type 'a v =
id:O.t
-> ssss:Ssss.t
-> dddd:ddd.t
-> t:S_m.t
-> mmm:Safe_float.t
-> qqq:int
-> c:C.t
-> uuuu:string option
-> aaaaaa:Aaaaaa.t
-> a:A.t
-> rrrrr:Rrrrr.t
-> time:Time.t
-> typ:[ `L_p of Safe_float.t ]
-> bazonk:present option
-> o_p_e:O_m.t option
-> only_hjkl:present option
-> show_junk:int option
-> d_p_o: Safe_float.t option
-> asdf:present option
-> generic:Sexp.t list
-> 'a
;; (* Not in mantis. *)
let bar x =
if y
then x
else z
let zot x =
quux ~f:(if x
then y
else z)
let zot x = quux ~f:(if x
then y
else z)
let () =
if foo
then bar
else if foo1
then zot
else bazonk
let () =
if foo
then bar
else
if foo1
then zot
else bazonk
let _ =
if until
then _
let () =
if a then (
b
) else (
c
)
let rec count_append l1 l2 count =
(* http://caml.inria.fr/resources/doc/guides/guidelines.en.html *)
match l1 with
| [] -> l2
| [x1] -> x1 :: l2
| [x1; x2] -> x1 :: x2 :: l2
| [x1; x2; x3] -> x1 :: x2 :: x3 :: l2
| [x1; x2; x3; x4] -> x1 :: x2 :: x3 :: x4 :: l2
| x1 :: x2 :: x3 :: x4 :: x5 :: tl ->
x1 :: x2 :: x3 :: x4 :: x5 ::
(if count > 1000
then slow_append tl l2
else count_append tl l2 (count + 1))
(* New in OCaml-4.02. *)
| exception Not_Found ->
l2
let x =
match x with
| Foo of
< tag : t; (* FIXME *)
md : t;
is_me : t;
>
;;
let x =
match x with
| Foo of
<
tag : t; (* FIXME *)
md : t;
is_me : t;
>
;;
let foo =
(
if a
then b
else c
)
let foo x = function
| Some _ -> true
| None -> false
let bar x = fun u ->
match u with
| Some _ -> true
| None -> false
let zot u = match u with
| Some _ -> true
| None -> false
let () = match x with
Foo -> 1
| Bar -> 2
let () =
match x with
Foo -> 1
| Bar -> 2
let r x =
try f x;
g x;
y x;
with e -> raise e
let g x =
try let a = b in
f x;
g x;
y x;
with e -> raise e
let () =
try
_
with
Bar -> ()
let () =
(* http://caml.inria.fr/resources/doc/guides/guidelines.en.html *)
try () with
| e ->
let x = z in
yyyyy
(a b)
let f = function
A ->
1
| B ->
2
let d x = function
(* FIXME: Should we leave it like this or align "|" with "match"?
I chose with "match" because it looks otherwise odd and is more
consistent with the "try" alignments above. *)
| A -> (match x with
| X ->
false
| Y -> true
| Z ->
false)
| B -> false
let a f = function
| A ->
1
| B ->
2
| C ->
(function
| X ->
a
| Y ->
b) 12
| D ->
(match z with
| 4 -> 3
| 5 -> 7)
let f = function x ->
y
let f x =
(let y = x in
f x;
g y;
h z)
let f x =
(let y = x in
f x);
g y;
h z
let g y =
a b;
c d;
e f;
(* Comment. *)
g h;
i j
let () =
(let a = 1 in
let b = 2 in
( a,
b))
let () =
((a b
c d e,
f g h),
( i j
k l,
m n
o p))
let () =
if a
then
let b = P.s ~b ~a ~m in
a +. e *. b,
b -. e *. b
else
q.a -. s *. z,
q.b +. s *. z
let () =
(* Comment. *)
(let x =
3
in
x + 5)
let foo = 1 and bar = 2 and zot = 3 in
let quux = 4 in
foo
+ bar
+ zot
+ quux
(* Indent comment to following code. *)
let () =
try (* foo!
bar *)
let a = f g c d in
a b
with _ -> ()
let () = try
f x;
with _ -> ()
let () = (try
f x;
with _ -> ())
let () =
try f a
with A () ->
()
| B () ->
()
| C () ->
()
let f errors input =
let ( @@ ) string bool = if not bool then errors := string :: !errors in
input @@ false
let x =
if mode = foo then bar;
conn
>>| fun x -> x + 1
>>| fun x -> x + 1
>>| fun x -> x + 1
let () =
match _ with
| foo ->
bar
>>| function _ ->
_
let () =
a
>>= fun () ->
b
>>| fun () ->
Deferred.all
let x =
v
>>= fun x -> y
>>= fun z -> w
>>= fun q -> r
let x =
v 1 2
3 4
5 6 >>= fun x ->
y+1 >>= (* foo! *) fun z ->
f 1 2 3
4 5 6 >>= fun y ->
w*3 >>= fun q -> r
(* This does not work, see comment in tuareg-compute-arrow-indent.
* Workaround: wrap code in parens. *)
(* let () =
* match
* a 1 2 3
* 4 5 6 >>= fun a ->
* b >>= fun b ->
* c
* with
* | A -> _ *)
let () =
match
let a = a in
let b = b in
c
with
| A -> _
let () =
match
(a >>= fun a ->
b >>= fun b ->
c)
with
A -> _
let f t =
let (a, b) = to_open in
let c = g t a b in
()
let () =
begin
foo bar
end
>>= fun () ->
begin
foo
bar
end
>>= fun () ->
()
let () =
(
foo bar
)
>>= fun () ->
(
foo
bar
)
>>= fun () ->
()
let () =
match e with
| `T d ->
notify `O `T d;
cancel t u ~now
let () =
let a = 1
and b = 2
and c = 3 in
a + b + c
let _ =
foo bar
|| snoo blue
let _ =
(
foo bar
|| snoo blue
)
let _ =
(foo bar
|| snoo blue)
let () =
Config.load ()
>>> fun config ->
let quux = config.Config.bazonk.Config.Bazonk.quux in
load_quux ~input quux config
>>> fun quux ->
let da = Poo.Snapshot.merge quux in
load_foobar config ~input
>>> fun foobar ->
whatever foobar
let () =
a
>>> fun () ->
b
let () =
a
>>= function
| b -> c
| d ->
e
>>= f
let () =
foo >>> fun bar ->
baz >>> fun zot ->
quux
let () =
Config.load ()
>>> fun config ->
let quux = x in
x
>>= fun quux ->
x
let () =
Config.load ()
>>= fun config ->
let quux = x in
x
>>= fun quux ->
x
let () =
f 1
|! (fun x ->
g x x)
|! (fun y ->
h y y)
let () =
(let a,b = match c with
| D -> e,f
| G -> h,i in
let j = a + b in
j * j),
12
module type M = M2
with type t1 = int
and type t2 = int
and module S = M3
with type t2 = int
with type t3 = int
let () =
try
match () with
| () -> ()
with _ -> ()
let () =
try
()
with _ -> ()
let () =
( try ()
with _ -> ())
let x =
foo ~bar
@ snoo
let x =
foo ~bar:snoo
@ snoo
let () =
IO.println
out (tagL
"ol" (List.map
~f:(tag ~a:[] "li") (
(List.map
results ~f:(fun (what,_) ->
tag "a" ~a:[("href","#" ^ what)] (what_title what)))
@ [tag "a" ~a:[("href","#" ^ message_id)] message_title;
tag "a" ~a:[("href","#" ^ legend_id)] legend_title])))
let x =
let y =
(a
^ b
^ c) in
f ~a:b ?c:d
?e:f ~g:(h i j)
~k:(l m)
(n o p)
let () =
foobar (fun () ->
step1
>>= fun () -> step2)
class c (a : b) =
object
inherit d
method m = 1
end
class c (a : b) =
object(self)
inherit d
method m = 1
end
class c (a : b) = object
inherit d
method m = 1
end
class c (a : b) = object(self)
inherit d
method m = 1
end
class type restricted_point_type =
object
method get_x : int
method bump : unit
end
class type restricted_point_type = object
method get_x : int
method bump : unit
end
let f = {
a = 1;
}
let f a = {
a = a;
}
let f a
b = {
a = a;
b = b;
}
let () =
for i = 10 to 17 do
printf "%d" i;
done
let () =
f a ~b:c ~d ~e:g
u ~q:[
"a";
"b";
]
let a = match b with
| Some c -> Some {
d = c;
e = e
}
| None -> {
d = c;
e = e
}
let a = {
b = (
let z = f u in
z + z;
);
c = (let a = b in {
z = z;
y = h;
});
}
let () =
{ A.
b =
C.d e ~f:(fun g -> (h.I.j.K.l, m))
|! begin fun n ->
match O.p n with
| `Q r -> r
| `S _k -> assert false
end;
t =
u ~v:w
~x:(Y.z a);
b =
c ~d:e
~f:(G.h i);
j =
K.l (fun m -> (N.o p m).R.S.t);
u =
V.w (fun x -> (Y.x a x).R.S.t);
v =
V.w (fun d ->
(D.g i d).R.S.z);
}
let x =
[(W.background `Blue (W.hbox [
x
]));
]
let c f =
if S.is_file f then
S.load f C.t
|! fun x -> c := Some x
else
C.s C.default |! S.save f
|! fun () -> c := None
let c f =
if S.is_file f then (
S.load f C.t
|! fun x -> c := Some x
) else (
C.s C.default |! S.save f
|! fun () -> c := None)
let foo x =
f1 x >= f2 x
&& f3
(f4 x)
let foo x =
(>=)
(f1 x) (f2 x)
&& f3
(f4 x)
let a =
foo
(fun () ->
a)
let a =
foo
~f:(fun () ->
a)
let a =
foo
(fun () -> a
)
let check =
a lsr 30 >= 3
&& b lsr 20 >= 1
&& c * 10 > f
let f a1 a2 a3
b1 b2 b3 d1 d2 d3 = {
aa = func1 a1 a2 a3;
bb = func2
b1 b2 b3;
(* FIXME: Here it is reasonable to have '|' aligned with 'match' *)
cc = (match c with
| A -> 1
| B -> 2);
dd = func3
d1 d2 d3;
}
let fv =
map3
a
b
c
~f:(fun
x
y
z
->
match x y z with
| `No)
(* https://forge.ocamlcore.org/tracker/index.php?func=detail&aid=644&group_id=43&atid=255 *)
let b =
match z with
| 0 -> fun x -> x
| 1 -> fun x -> 1
module type X =
struct
val f : float -> float
(** This comment should be under "val", like other doc comments and not
aligned to the left margin. *)
end
let test () = (* bug#927 *)
if a then
if b then x
else if c then y
else z
else something
let f x =
if x = 1 then print "hello";
print "there";
print "everywhere"
let f x =
if print "hello"; x = 1 then print "hello";
print "there"
let f x =
if x = 1 then let y = 2 in print "hello";
print "there"
else print "toto"
let f x =
match x with
| 1 -> let x = 2 in
if x = 1 then print "hello"
| 2 -> print "there"
let f x =
if x = 1 then match x with
| 1 -> print "hello"
| 2 -> print "there"
else print "toto"
let f x =
x + 4 +
x + 5 +
x + 6
let splitting_long_expression =
quad.{band, i3} <- quad.{band, i3} +. g +.
area_12 *. (P.potential x13 y13 +. P.potential x23 y23)
let () =
(* Beware of lexing ".;" as a single token! *)
A.Axes.box vp;
A.fx vp (E.on_ray u0) 0. 2000.;
A.Viewport.set_color vp A.Color.green
let f x =
1
and g y =
2
let x =
let module M =
struct
end
in 0
let x =
try a
with Not_found ->
b
| _ ->
c
let x =
try a
with Not_found ->
if a then b
| flag when String.is_prefix flag ~prefix:"-" ->
a
| _ ->
c
let x = "toto try \
tata"
let () =
f x ~tol:1.0
more arguments;
f x ~tol:1.
more arguments
type t = {
mutable a: float;
b : int;
}
(* [struct] and [sig] must be treated the same way. *)
module Base64 : sig
val f : int -> int
end
external f :
int -> unit (* Treated as [val]. *)
= "f_stub"
let () =
g a.[k]
x (* aligned with [a], despite the dot *)
let () =
g a.[k] 1.0
x (* aligned with [a], despite the dots *)
(* OOP elements (from Marc Simpson ). *)
class useless = object
val n = 10
method incremented () =
succ n
method add_option = function
| Some x -> Some(n + x)
| None -> None
end
class useless' = object(self)
val n = 10
method incremented () =
succ n
method add_option = function
| Some x -> Some(n + x)
| None -> None
end
class useless' = object(self)
val n = 10
initializer
print_endline "Initialised."
method incremented () =
succ n
method private add x =
n + x
method add_option = function
| Some x -> Some(self#add x)
| None -> None
end
(* Signatures with labeled arguments *)
val f :
x : int ->
int ->
int
val f :
?x : int ->
int ->
int
let x = List.map
(function x ->
blabla
blabla
blabla)
l
(* The two "let"s below are indented under the assumption that
tuareg-indent-align-with-first-arg is nil! *)
let x = List.map (fun x -> 5)
my list
let x =
logf `Info "User %s has %i new messages" ba
(Uid.to_string uid)
(List.length new_messages)
(* MetaOCaml thingies, issue #195. *)
let f x = .< 0.0 + g .~ x
5
* 7
+ .<.~x
+. 10>.
>.
let f = function
| A -> 1
| B | C -> 2
let quux list = List.map list ~f:(fun item ->
print_item item
)
let h x =
try ff a b
c d;
gg 1 2
3 4;
with e -> raise e
let x = foo ~f:(fun _ -> 0 (* Comment. *)
)
let x =
let foo = 1 and bar = 2 and zot = 3 in
let quux = 4 in
foo
+ bar
+ zot
+ quux
let () =
foo (sprintf ("a: %s"
^ " b: %s")
a
b)
let () =
Hashtbl.iter times ~f:(fun ~key:time ~data:azot ->
Clock.at time
>>> fun () ->
Db.iter t.db ~f:(fun dbo ->
if S.mem azot (Dbo.azo dbo) then
Dbo.dont dbo))
let () =
f 1
|> (fun x ->
g x x)
|> (fun y ->
h y y)
let () =
tagL "ol" (List.map ~f:(tag ~a:[] "li") (
(List.map results ~f:(fun (what,_) ->
tag "a" ~a:[("href","#" ^ what)] (what_title what)))
@ [tag "a" ~a:[("href","#" ^ message_id)] message_title;
tag "a" ~a:[("href","#" ^ legend_id)] legend_title]))
|> IO.println out
let w f =
List.map f ~f:(fun (a, b) ->
L.r a
>>= function
| Ok s -> `Fst (b, s)
| Error e -> `Snd (b, a, e))
let a =
B.c d ~e:f [
"g";
"h";
]
let x =
[(W.background `Blue (W.hbox [
x
]));
]
let c f =
if S.is_file f then
S.load f C.t
|> fun x -> c := Some x
else
C.s C.default |> S.save f
|> fun () -> c := None
let c f =
if S.is_file f then (
S.load f C.t
|> fun x -> c := Some x
) else (
C.s C.default |> S.save f
|> fun () -> c := None)
let a =
foo
(fun () ->
a)
let a =
foo
~f:(fun () ->
a)
let a =
foo
(fun () -> a
)
let a =
foo
~f:(fun () -> a
)
let () =
(* Comment. *)
bar a b
c d;
foo ~size
(* Comment. *)
~min:foo
?reduce
?override
()
let foo =
(* Comment. *)
List.map z
~f:(fun m ->
M.q m
|> T.u ~pr ~verbose:false
~p:H.P.US ~is_bar:false)
|> List.sort ~cmp:(fun a b ->
compare
(I.r a.T.s)
(I.r b.T.s))
let () =
snoo ~f:(fun foo ->
foo = bar
&& snoo)
let () =
snoo ~f:(fun foo ->
foo + bar
&& snoo)
let () =
snoo ~f:(fun foo ->
foo
&& snoo)
let variants a =
match String.split a ~on:'-' with
| [ s1; s2; s3 ] ->
let a0 = String.concat ~sep:"" [ s1; s2] in
let a1 = String.concat ~sep:"-" [ s1; s2; s3; "055" ] in (* Comment. *)
List.map [ a0; a1; a]
~f:(fun a_s -> lookup a_s)
|> List.flatten
| _ -> failwith "bad"
let x =
try a
with Not_found ->
b
let optional_sci_float =
do_something ~a:1e-7
~b:(fun x -> x + 1)
let array_args =
fold s multi_sms.(0).message_number folder
more_args (* FIXME *)
type t = {
mutable a: float;
b : int;
}
let subscribe_impl dir topic ~aborted =
return (
match Directory.subscribe dir topic with
| None -> Error ()
| Some pipe ->
whenever (aborted >>| fun () -> Pipe.close_read pipe);
Ok pipe
)
next_argument (* should be indented correctly, given the braces *)
let command =
Command.Spec.(
empty
+> flag "-hello" (optional_with_default "Hello" string)
~doc:" The 'hello' of 'hello world'"
+> flag "-world" (optional_with_default "World" string)
~doc:" The 'world' of 'hello world'"
)
tuareg-3.0.1/ocamldebug.el 0000664 0000000 0000000 00000101756 14315315656 0015451 0 ustar 00root root 0000000 0000000 ;;; ocamldebug.el --- Run ocamldebug / camldebug under Emacs -*- lexical-binding:t -*-
;; Derived from gdb.el.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Copying is covered by the GNU General Public License.
;;
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; History:
;;
;;itz 04-06-96 I pondered basing this on gud. The potential advantages
;;were: automatic bugfix , keymaps and menus propagation.
;;Disadvantages: gud is not so clean itself, there is little common
;;functionality it abstracts (most of the stuff is done in the
;;debugger specific parts anyway), and, most seriously, gud sees it
;;fit to add C-x C-a bindings to the _global_ map, so there would be a
;;conflict between ocamldebug and gdb, for instance. While it's OK to
;;assume that a sane person doesn't use gdb and dbx at the same time,
;;it's not so OK (IMHO) for gdb and ocamldebug.
;;Albert Cohen 04-97: Patch for Tuareg support.
;;Albert Cohen 05-98: A few patches and OCaml customization.
;;Albert Cohen 09-98: XEmacs support and some improvements.
;;Erwan Jahier and Albert Cohen 11-05: support for ocamldebug 3.09.
;;; Commentary:
;;; Code:
(require 'comint)
(require 'shell)
(require 'tuareg (expand-file-name "tuareg" (file-name-directory
(or load-file-name
byte-compile-current-file
buffer-file-name))))
(require 'derived)
;;; Variables.
(defvar ocamldebug-last-frame)
(defvar ocamldebug-delete-prompt-marker)
(defvar ocamldebug-filter-accumulator nil)
(defvar ocamldebug-last-frame-displayed-p)
(defvar ocamldebug-filter-function)
(defvar ocamldebug-kill-output)
(defvar ocamldebug-current-buffer nil)
(defvar ocamldebug-goto-position)
(defvar ocamldebug-goto-output)
(defvar ocamldebug-delete-file)
(defvar ocamldebug-delete-position)
(defvar ocamldebug-delete-output)
(defvar ocamldebug-complete-list)
(defvar ocamldebug-prompt-pattern "^(\\(ocd\\|cdb\\)) *"
"A regexp to recognize the prompt for ocamldebug.")
(defvar ocamldebug-overlay-event
(let ((ol (make-overlay (point) (point))))
(overlay-put ol 'face 'ocamldebug-event)
(delete-overlay ol) ;; Disconnect it from current buffer.
ol)
"Overlay for displaying the first/last char of current event.")
(defvar ocamldebug-overlay-under
(let ((ol (make-overlay (point) (point))))
(overlay-put ol 'face 'ocamldebug-underline)
(delete-overlay ol) ;; Disconnect it from current buffer.
ol)
"Overlay for displaying the rest of current event.")
(defvar ocamldebug-event-marker (make-marker)
"Marker for displaying the current event.")
(defvar ocamldebug-track-frame t
"If non-nil, always display current frame position in another window.")
(defface ocamldebug-event
'((t :invert t))
"Face to highlight the first/last char of current event."
:group 'tuareg)
(defface ocamldebug-underline
;; FIXME: The name should describe what it's used for, not what it looks
;; like by default!
'((t :underline t))
"Face to highlight the rest of current event."
:group 'tuareg)
;;; OCamldebug mode.
(defvar ocamldebug-prefix-map (make-sparse-keymap)
"Keymap bound to prefix keys in `ocamldebug-mode' and `tuareg-mode'.")
(define-key tuareg-mode-map "\C-x\C-a" ocamldebug-prefix-map)
(defvar ocamldebug-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "\C-c" ocamldebug-prefix-map)
(define-key map "\C-l" #'ocamldebug-refresh)
;; This is already the default anyway!
;;(define-key map "\t" 'comint-dynamic-complete)
(define-key map "\M-?"
;; FIXME: This binding is wrong since comint-dynamic-list-completions
;; is a function, not a command.
#'comint-dynamic-list-completions)
map))
(define-derived-mode ocamldebug-mode comint-mode "OCaml-Debugger"
"Major mode for interacting with an ocamldebug process.
The following commands are available:
\\{ocamldebug-mode-map}
\\[ocamldebug-display-frame] displays in the other window
the last line referred to in the ocamldebug buffer.
\\[ocamldebug-step], \\[ocamldebug-back] and \\[ocamldebug-next], in the ocamldebug window,
call ocamldebug to step, backstep or next and then update the other window
with the current file and position.
If you are in a source file, you may select a point to break
at, by doing \\[ocamldebug-break].
Commands:
Many commands are inherited from comint mode.
Additionally we have:
\\[ocamldebug-display-frame] display frames file in other window
\\[ocamldebug-step] advance one line in program
C-x SPACE sets break point at current line."
(setq-local ocamldebug-last-frame nil)
(setq-local ocamldebug-delete-prompt-marker (make-marker))
(setq-local ocamldebug-filter-accumulator "")
(setq-local ocamldebug-filter-function #'ocamldebug-marker-filter)
(setq-local comint-prompt-regexp ocamldebug-prompt-pattern)
(add-hook 'comint-dynamic-complete-functions #'ocamldebug-capf nil 'local)
(setq-local comint-prompt-read-only t)
(setq-local paragraph-start comint-prompt-regexp)
(setq-local ocamldebug-last-frame-displayed-p t)
(setq-local shell-dirtrackp t)
(add-hook 'comint-input-filter-functions #'shell-directory-tracker nil t))
;;; Keymaps.
(defun ocamldebug-numeric-arg (arg)
(and arg (prefix-numeric-value arg)))
(defmacro def-ocamldebug (name key &optional doc args)
"Define ocamldebug-NAME to be a command sending NAME ARGS and bound
to KEY, with optional doc string DOC. Certain %-escapes in ARGS are
interpreted specially if present. These are:
%m module name of current module.
%d directory of current source file.
%c number of current character position
%e text of the OCaml variable surrounding point.
The `current' source file is the file of the current buffer (if
we're in an OCaml buffer) or the source file current at the last break
or step (if we're in the ocamldebug buffer), and the `current' module
name is the filename stripped of any *.ml* suffixes (this assumes the
usual correspondence between module and file naming is observed). The
`current' position is that of the current buffer (if we're in a source
file) or the position of the last break or step (if we're in the
ocamldebug buffer).
If a numeric is present, it overrides any ARGS flags and its string
representation is simply concatenated with the COMMAND."
(let* ((fun (intern (format "ocamldebug-%s" name))))
`(progn
,(if doc
`(defun ,fun (arg)
,doc
(interactive "P")
(ocamldebug-call ,name ,args
(ocamldebug-numeric-arg arg))))
(define-key ocamldebug-prefix-map ,key #',fun))))
(def-ocamldebug "step" "\C-s" "Step one source line with display.")
(def-ocamldebug "run" "\C-r" "Run the program.")
(def-ocamldebug "reverse" "\C-v" "Run the program in reverse.")
(def-ocamldebug "last" "\C-l" "Go to latest time in execution history.")
(def-ocamldebug "backtrace" "\C-t" "Print the call stack.")
(def-ocamldebug "open" "\C-o" "Open the current module." "%m")
(def-ocamldebug "close" "\C-c" "Close the current module." "%m")
(def-ocamldebug "finish" "\C-f" "Finish executing current function.")
(def-ocamldebug "print" "\C-p" "Print value of symbol at point." "%e")
(def-ocamldebug "next" "\C-n" "Step one source line (skip functions)")
(def-ocamldebug "up" "<" "Go up N stack frames (numeric arg) with display")
(def-ocamldebug "down" ">" "Go down N stack frames (numeric arg) with display")
(def-ocamldebug "break" "\C-b" "Set breakpoint at current line."
"@ \"%m\" # %c")
(defun ocamldebug-kill-filter (string)
;; Gob up stupid questions :-)
(setq ocamldebug-filter-accumulator
(concat ocamldebug-filter-accumulator string))
(when (string-match "\\(.* \\)(y or n) " ocamldebug-filter-accumulator)
(setq ocamldebug-kill-output
(cons t (match-string 1 ocamldebug-filter-accumulator)))
(setq ocamldebug-filter-accumulator ""))
(if (string-match comint-prompt-regexp ocamldebug-filter-accumulator)
(let ((output (substring ocamldebug-filter-accumulator
(match-beginning 0))))
(setq ocamldebug-kill-output
(cons nil (substring ocamldebug-filter-accumulator 0
(1- (match-beginning 0)))))
(setq ocamldebug-filter-accumulator "")
output)
""))
(def-ocamldebug "kill" "\C-k")
(defun ocamldebug-kill ()
"Kill the program."
(interactive)
(let (ocamldebug-kill-output)
(with-current-buffer ocamldebug-current-buffer
(let ((proc (get-buffer-process (current-buffer)))
(ocamldebug-filter-function #'ocamldebug-kill-filter))
(ocamldebug-call "kill")
(while (not (and ocamldebug-kill-output
(zerop (length ocamldebug-filter-accumulator))))
(accept-process-output proc))))
(if (not (car ocamldebug-kill-output))
(error (cdr ocamldebug-kill-output))
(sit-for 0.3)
(ocamldebug-call-1 (if (y-or-n-p (cdr ocamldebug-kill-output)) "y" "n")))))
;;FIXME: ocamldebug doesn't output the Hide marker on kill
(defun ocamldebug-goto-filter (string)
;; Accumulate onto previous output
(setq ocamldebug-filter-accumulator
(concat ocamldebug-filter-accumulator string))
;; Address Characters Kind Repr.
;; 14452 64-82 before/fun
;; 14584 182-217 after/ret
;;0: 30248 -1--1 pseudo
;;0: 30076 64-82 before/fun
(when (or (string-match
(concat "\\(?:\n\\|\\`\\)[ \t]*"
"\\([0-9]+\\)\\(?::[ \t]*\\([0-9]+\\)\\)?[ \t]+"
ocamldebug-goto-position
"-[0-9]+[ \t]*before.*\n")
ocamldebug-filter-accumulator)
(string-match
(concat "\\(?:\n\\|\\`\\)[ \t]*"
"\\([0-9]+\\)\\(?::[ \t]*\\([0-9]+\\)\\)?[ \t]+[0-9]+-"
ocamldebug-goto-position
"[ \t]*after.*\n")
ocamldebug-filter-accumulator))
(let ((id (match-string 1 ocamldebug-filter-accumulator))
(pos (match-string 2 ocamldebug-filter-accumulator)))
(setq ocamldebug-goto-output (if pos (concat id ":" pos) id)))
(setq ocamldebug-filter-accumulator
(substring ocamldebug-filter-accumulator (1- (match-end 0)))))
(when (string-match comint-prompt-regexp ocamldebug-filter-accumulator)
(setq ocamldebug-goto-output (or ocamldebug-goto-output 'fail))
(setq ocamldebug-filter-accumulator ""))
(when (string-match "\n\\(.*\\)\\'" ocamldebug-filter-accumulator)
(setq ocamldebug-filter-accumulator
(match-string 1 ocamldebug-filter-accumulator)))
"")
(def-ocamldebug "goto" "\C-g")
(defun ocamldebug-goto (&optional time)
"Go to the execution time TIME.
Without TIME, the command behaves as follows: In the ocamldebug buffer,
if the point at buffer end, goto time 0; otherwise, try to obtain the
time from context around point. In an OCaml buffer, try to find the
time associated in execution history with the current point location.
With a negative TIME, move that many lines backward in the ocamldebug
buffer, then try to obtain the time from context around point."
(interactive "P")
(cond
(time
(let ((ntime (ocamldebug-numeric-arg time)))
(if (>= ntime 0) (ocamldebug-call "goto" nil ntime)
(save-selected-window
(select-window (get-buffer-window ocamldebug-current-buffer))
(save-excursion
(if (re-search-backward
"^Time *: [0-9]+ - pc *: [0-9]+\\(?::[0-9]+\\)? "
nil t (- 1 ntime))
(ocamldebug-goto nil)
(error "I don't have %d times in my history"
(- 1 ntime))))))))
((eq (current-buffer) ocamldebug-current-buffer)
(let ((time (cond
((eobp) 0)
((save-excursion
(beginning-of-line 1)
(looking-at
"^Time *: \\([0-9]+\\) - pc *: [0-9]+\\(?::[0-9]+\\)? "))
(string-to-number (match-string 1)))
((string-to-number (ocamldebug-format-command "%e"))))))
(ocamldebug-call "goto" nil time)))
(t
(let ((module (ocamldebug-module-name (buffer-file-name)))
(ocamldebug-goto-position (int-to-string (1- (point))))
ocamldebug-goto-output address)
;; Get a list of all events in the current module
(with-current-buffer ocamldebug-current-buffer
(let* ((proc (get-buffer-process (current-buffer)))
(ocamldebug-filter-function #'ocamldebug-goto-filter))
(ocamldebug-call-1 (concat "info events " module))
(while (not (and ocamldebug-goto-output
(zerop (length ocamldebug-filter-accumulator))))
(accept-process-output proc))
(setq address (unless (eq ocamldebug-goto-output 'fail)
(re-search-backward
(concat "^Time *: \\([0-9]+\\) - pc *: "
ocamldebug-goto-output
" - module "
module "$")
nil t)
(match-string 1)))))
(if address (ocamldebug-call "goto" nil (string-to-number address))
(error "No time at %s at %s" module ocamldebug-goto-position))))))
(defun ocamldebug-delete-filter (string)
(setq ocamldebug-filter-accumulator
(concat ocamldebug-filter-accumulator string))
(when (string-match
;; Num Address Where
;; 1 14552 file u.ml, line 5, characters 1-34
;; 1 0: 30176 file u.ml, line 5, characters 1-34
(concat "\\(?:\n\\|\\`\\)[ \t]*\\([0-9]+\\)[ \t]+"
"[0-9]+\\(?::[ \t]*[0-9]+\\)?[ \t]+file +"
(regexp-quote ocamldebug-delete-file)
", character "
ocamldebug-delete-position "\n")
ocamldebug-filter-accumulator)
(setq ocamldebug-delete-output
(match-string 1 ocamldebug-filter-accumulator))
(setq ocamldebug-filter-accumulator
(substring ocamldebug-filter-accumulator (1- (match-end 0)))))
(when (string-match comint-prompt-regexp
ocamldebug-filter-accumulator)
(setq ocamldebug-delete-output (or ocamldebug-delete-output 'fail))
(setq ocamldebug-filter-accumulator ""))
(if (string-match "\n\\(.*\\)\\'" ocamldebug-filter-accumulator)
(setq ocamldebug-filter-accumulator
(match-string 1 ocamldebug-filter-accumulator)))
"")
(def-ocamldebug "delete" "\C-d")
(defun ocamldebug-delete (&optional arg)
"Delete the breakpoint numbered ARG.
Without ARG, the command behaves as follows: In the ocamldebug buffer,
try to obtain the time from context around point. In an OCaml buffer,
try to find the breakpoint associated with the current point location.
With a negative ARG, look for the -ARGth breakpoint pattern in the
ocamldebug buffer, then try to obtain the breakpoint info from context
around point."
(interactive "P")
(cond
(arg
(let ((narg (ocamldebug-numeric-arg arg)))
(if (> narg 0) (ocamldebug-call "delete" nil narg)
(with-current-buffer ocamldebug-current-buffer
(if (re-search-backward
"^Breakpoint [0-9]+ at [0-9]+\\(?::[0-9]+\\)? *: file "
nil t (- 1 narg))
(ocamldebug-delete nil)
(error "I don't have %d breakpoints in my history"
(- 1 narg)))))))
((eq (current-buffer) ocamldebug-current-buffer)
(let* ((bpline
"^Breakpoint \\([0-9]+\\) at [0-9]+\\(?::[0-9]+\\)? *: file ")
(arg (cond
((eobp)
(save-excursion (re-search-backward bpline nil t))
(string-to-number (match-string 1)))
((save-excursion
(beginning-of-line 1)
(looking-at bpline))
(string-to-number (match-string 1)))
((string-to-number (ocamldebug-format-command "%e"))))))
(ocamldebug-call "delete" nil arg)))
(t
(let ((ocamldebug-delete-file
(concat (ocamldebug-format-command "%m") ".ml"))
(ocamldebug-delete-position (ocamldebug-format-command "%c")))
(with-current-buffer ocamldebug-current-buffer
(let ((proc (get-buffer-process (current-buffer)))
(ocamldebug-filter-function #'ocamldebug-delete-filter)
ocamldebug-delete-output)
(ocamldebug-call-1 "info break")
(while (not (and ocamldebug-delete-output
(zerop (length
ocamldebug-filter-accumulator))))
(accept-process-output proc))
(if (eq ocamldebug-delete-output 'fail)
(error "No breakpoint in %s at %s"
ocamldebug-delete-file
ocamldebug-delete-position)
(ocamldebug-call "delete" nil
(string-to-number ocamldebug-delete-output)))))))))
(defun ocamldebug-complete-filter (string)
(setq ocamldebug-filter-accumulator
(concat ocamldebug-filter-accumulator string))
(while (string-match "\\(\n\\|\\`\\)\\(.+\\)\n"
ocamldebug-filter-accumulator)
(setq ocamldebug-complete-list
(cons (match-string 2 ocamldebug-filter-accumulator)
ocamldebug-complete-list))
(setq ocamldebug-filter-accumulator
(substring ocamldebug-filter-accumulator
(1- (match-end 0)))))
(when (string-match comint-prompt-regexp
ocamldebug-filter-accumulator)
(setq ocamldebug-complete-list
(or ocamldebug-complete-list 'fail))
(setq ocamldebug-filter-accumulator ""))
(if (string-match "\n\\(.*\\)\\'" ocamldebug-filter-accumulator)
(setq ocamldebug-filter-accumulator
(match-string 1 ocamldebug-filter-accumulator)))
"")
(defun ocamldebug-complete ()
"Perform completion on the ocamldebug command preceding point."
(interactive)
(let* ((capf-data (ocamldebug-capf))
(command-word (buffer-substring (nth 0 capf-data) (nth 1 capf-data))))
(completion-in-region (nth 0 capf-data) (nth 1 capf-data)
(sort (all-completions command-word (nth 2 capf-data))
#'string-lessp))))
(make-obsolete 'ocamldebug-complete 'completion-at-point "24.1")
(defun ocamldebug-capf ()
;; FIXME: Use an `end' after point when applicable.
(let* ((end (point))
(cmd-start (save-excursion
(beginning-of-line)
(if (looking-at comint-prompt-regexp)
(match-end 0) (point))))
(start (save-excursion
(skip-chars-backward "^ \n" cmd-start)
(point))))
`(,start ,end
,(completion-table-dynamic
(apply-partially #'ocamldebug--get-completions
(buffer-substring cmd-start start))))))
(defun ocamldebug--get-completions (command-prefix str)
;; FIXME: Add some caching?
(let ((ocamldebug-complete-list nil))
;; itz 04-21-96 If we are trying to complete a word of nonzero
;; length, chop off the last character. This is a nasty hack, but it
;; works - in general, not just for this set of words: the completion
;; code will weed out false matches - and it avoids further
;; mucking with ocamldebug's lexer.
;; FIXME: Which problem is this trying to fix/avoid/circumvent?
(when (> (length str) 0)
(setq str (substring str 0 (1- (length str)))))
(let ((ocamldebug-filter-function #'ocamldebug-complete-filter))
(ocamldebug-call-1 (concat "complete " command-prefix str))
(set-marker ocamldebug-delete-prompt-marker nil)
(while (not (and ocamldebug-complete-list
(zerop (length ocamldebug-filter-accumulator))))
(accept-process-output (get-buffer-process
(current-buffer)))))
(if (eq ocamldebug-complete-list 'fail)
nil
ocamldebug-complete-list)))
(define-key tuareg-mode-map "\C-x " #'ocamldebug-break)
(defvar ocamldebug-command-name "ocamldebug"
"Pathname for executing the OCaml debugger.")
(defvar ocamldebug-debuggee-args ""
"Default arguments to the program being debugged (space
separated and possibly quoted as they would be passed on the
command line).")
;;;###autoload
(defun ocamldebug (pgm-path)
"Run ocamldebug on program FILE in buffer *ocamldebug-FILE*.
The directory containing FILE becomes the initial working directory
and source-file directory for ocamldebug. If you wish to change this, use
the ocamldebug commands `cd DIR' and `directory'."
(interactive "fRun ocamldebug on file: ")
(setq pgm-path (expand-file-name pgm-path))
(let* ((file (file-name-nondirectory pgm-path))
(name (concat "ocamldebug-" file))
(buffer-name (concat "*" name "*")))
(pop-to-buffer buffer-name)
(unless (comint-check-proc buffer-name)
(setq default-directory (file-name-directory pgm-path))
(setq ocamldebug-debuggee-args
(read-from-minibuffer (format "Args for %s: " file)
ocamldebug-debuggee-args))
(setq ocamldebug-command-name
(read-from-minibuffer "OCaml debugger to run: "
ocamldebug-command-name))
(message "Current directory is %s" default-directory)
(let* ((args (tuareg--split-args ocamldebug-debuggee-args))
(cmdlist (tuareg--split-args ocamldebug-command-name))
(cmdlist (mapcar #'substitute-in-file-name cmdlist)))
(apply #'make-comint name
(car cmdlist)
nil
"-emacs" "-cd" default-directory
(append (cdr cmdlist) (cons pgm-path args)))
(set-process-filter (get-buffer-process (current-buffer))
#'ocamldebug-filter)
(set-process-sentinel (get-buffer-process (current-buffer))
#'ocamldebug-sentinel)
(ocamldebug-mode)))
(ocamldebug-set-buffer)))
;;;###autoload
(defalias 'camldebug #'ocamldebug)
(defun ocamldebug-set-buffer ()
(if (eq major-mode 'ocamldebug-mode)
(setq ocamldebug-current-buffer (current-buffer))
(save-selected-window (pop-to-buffer ocamldebug-current-buffer))))
;;; Filter and sentinel.
(defun ocamldebug-marker-filter (string)
(setq ocamldebug-filter-accumulator
(concat ocamldebug-filter-accumulator string))
(let ((output "") begin)
;; Process all the complete markers in this chunk.
(while (setq begin
(string-match
"\032\032\\(H\\|M\\(.+\\):\\(.+\\):\\(.+\\):\\(before\\|after\\)\\)\n"
ocamldebug-filter-accumulator))
(setq ocamldebug-last-frame
(unless (char-equal ?H (aref ocamldebug-filter-accumulator
(1+ (1+ begin))))
(let ((isbefore
(string= "before"
(match-string 5 ocamldebug-filter-accumulator)))
(startpos (string-to-number
(match-string 3 ocamldebug-filter-accumulator)))
(endpos (string-to-number
(match-string 4 ocamldebug-filter-accumulator))))
(list (match-string 2 ocamldebug-filter-accumulator)
(if isbefore startpos endpos)
isbefore
startpos
endpos
)))
output (concat output
(substring ocamldebug-filter-accumulator
0 begin))
;; Set the accumulator to the remaining text.
ocamldebug-filter-accumulator (substring
ocamldebug-filter-accumulator
(match-end 0))
ocamldebug-last-frame-displayed-p nil))
;; Does the remaining text look like it might end with the
;; beginning of another marker? If it does, then keep it in
;; ocamldebug-filter-accumulator until we receive the rest of it. Since we
;; know the full marker regexp above failed, it's pretty simple to
;; test for marker starts.
(if (string-match "\032.*\\'" ocamldebug-filter-accumulator)
(progn
;; Everything before the potential marker start can be output.
(setq output (concat output (substring ocamldebug-filter-accumulator
0 (match-beginning 0))))
;; Everything after, we save, to combine with later input.
(setq ocamldebug-filter-accumulator
(substring ocamldebug-filter-accumulator (match-beginning 0))))
(setq output (concat output ocamldebug-filter-accumulator)
ocamldebug-filter-accumulator ""))
output))
(defun ocamldebug-filter (proc string)
(when (buffer-name (process-buffer proc))
(let (process-window)
(with-current-buffer (process-buffer proc)
;; If we have been so requested, delete the debugger prompt.
(when (marker-buffer ocamldebug-delete-prompt-marker)
(delete-region (process-mark proc)
ocamldebug-delete-prompt-marker)
(set-marker ocamldebug-delete-prompt-marker nil))
(let ((output (funcall ocamldebug-filter-function string)))
;; Don't display the specified file unless
;; (1) point is at or after the position where output appears
;; and (2) this buffer is on the screen.
(setq process-window (and ocamldebug-track-frame
(not ocamldebug-last-frame-displayed-p)
(>= (point) (process-mark proc))
(get-buffer-window (current-buffer))))
;; Insert the text, moving the process-marker.
(comint-output-filter proc output)))
(when process-window
(save-selected-window
(select-window process-window)
(ocamldebug-display-frame))))))
(defun ocamldebug-sentinel (proc msg)
(cond ((null (buffer-name (process-buffer proc)))
;; buffer killed
;; Stop displaying an arrow in a source file.
(ocamldebug-remove-current-event)
(set-process-buffer proc nil))
((memq (process-status proc) '(signal exit))
;; Stop displaying an arrow in a source file.
(ocamldebug-remove-current-event)
;; Fix the mode line.
(setq mode-line-process
(concat ": "
(symbol-name (process-status proc))))
(let* ((obuf (current-buffer)))
;; save-excursion isn't the right thing if
;; process-buffer is current-buffer
(unwind-protect
(progn
;; Write something in *compilation* and hack its mode line,
(set-buffer (process-buffer proc))
;; Force mode line redisplay soon
(set-buffer-modified-p (buffer-modified-p))
(if (eobp)
(insert ?\n mode-name " " msg)
(save-excursion
(goto-char (point-max))
(insert ?\n mode-name " " msg)))
;; If buffer and mode line will show that the process
;; is dead, we can delete it now. Otherwise it
;; will stay around until M-x list-processes.
(delete-process proc))
;; Restore old buffer, but don't restore old point
;; if obuf is the cdb buffer.
(set-buffer obuf))))))
(defun ocamldebug-refresh (&optional arg)
"Fix up a possibly garbled display, and redraw the mark."
(interactive "P")
(ocamldebug-display-frame)
(recenter arg))
(defun ocamldebug-display-frame ()
"Find, obey and delete the last filename-and-line marker from OCaml debugger.
The marker looks like \\032\\032FILENAME:CHARACTER\\n.
Obeying it means displaying in another window the specified file and line."
(interactive)
(ocamldebug-set-buffer)
(if (not ocamldebug-last-frame)
(ocamldebug-remove-current-event)
(ocamldebug-display-line (nth 0 ocamldebug-last-frame)
(nth 3 ocamldebug-last-frame)
(nth 4 ocamldebug-last-frame)
(nth 2 ocamldebug-last-frame)))
(setq ocamldebug-last-frame-displayed-p t))
;; Make sure the file named TRUE-FILE is in a buffer that appears on the screen
;; and that its character CHARACTER is visible.
;; Put the mark on this character in that buffer.
(defun ocamldebug-display-line (true-file schar echar kind)
(let* ((pop-up-windows t)
(buffer (find-file-noselect true-file))
(window (display-buffer buffer t))
spos epos pos)
(with-current-buffer buffer
(save-restriction
(widen)
(setq spos (if (fboundp 'filepos-to-bufferpos)
(filepos-to-bufferpos schar 'approximate)
(+ (point-min) schar)))
(setq epos (if (fboundp 'filepos-to-bufferpos)
(filepos-to-bufferpos echar 'approximate)
(+ (point-min) echar)))
(setq pos (if kind spos epos))
(ocamldebug-set-current-event spos epos pos (current-buffer) kind))
(cond ((or (< pos (point-min)) (> pos (point-max)))
(widen)
(goto-char pos))))
(set-window-point window pos)))
;;; Events.
(defun ocamldebug-remove-current-event ()
(if window-system
(progn
(delete-overlay ocamldebug-overlay-event)
(delete-overlay ocamldebug-overlay-under))
(setq overlay-arrow-position nil)))
(defun ocamldebug-set-current-event (spos epos pos buffer before)
(if window-system
(if before
(progn
(move-overlay ocamldebug-overlay-event spos (1+ spos) buffer)
(move-overlay ocamldebug-overlay-under
(+ spos 1) epos buffer))
(move-overlay ocamldebug-overlay-event (1- epos) epos buffer)
(move-overlay ocamldebug-overlay-under spos (1- epos) buffer))
(with-current-buffer buffer
(goto-char pos)
(beginning-of-line)
(move-marker ocamldebug-event-marker (point))
(setq overlay-arrow-position ocamldebug-event-marker))))
;;; Miscellaneous.
(defun ocamldebug-module-name (filename)
(substring filename (string-match "\\([^/]*\\)\\.ml$" filename) (match-end 1)))
;; The ocamldebug-call function must do the right thing whether its
;; invoking keystroke is from the ocamldebug buffer itself (via
;; major-mode binding) or an OCaml buffer. In the former case, we want
;; to supply data from ocamldebug-last-frame. Here's how we do it:
(defun ocamldebug-format-command (str)
(let* ((insource (not (eq (current-buffer) ocamldebug-current-buffer)))
(frame (if insource nil ocamldebug-last-frame))
(result ""))
(while (and str (string-match "\\([^%]*\\)%\\([mdcep]\\)" str))
(let* ((key (aref str (match-beginning 2)))
(cmd (match-string 1 str))
(end (match-end 0))
(subst
(pcase key
(`?m
(ocamldebug-module-name
(if insource buffer-file-name (nth 0 frame))))
(`?d
(file-name-directory
(if insource buffer-file-name (nth 0 frame))))
(`?c
(int-to-string
;; FIXME: Should this be (- (point) (point-min))?
;; What happens with multibyte chars?
(if insource (1- (point)) (nth 1 frame))))
(`?e
(save-excursion
(skip-chars-backward "_0-9A-Za-z\277-\377")
(looking-at "[_0-9A-Za-z\277-\377]*")
(match-string 0))))))
(setq str (substring str end))
(setq result (concat result cmd subst))))
;; There might be text left in STR when the loop ends.
(concat result str)))
(defun ocamldebug-call (command &optional fmt arg)
"Invoke ocamldebug COMMAND displaying source in other window.
Certain %-escapes in FMT are interpreted specially if present.
These are:
%m module name of current module.
%d directory of current source file.
%c number of current character position
%e text of the OCaml variable surrounding point.
The `current' source file is the file of the current buffer (if
we're in an OCaml buffer) or the source file current at the last break
or step (if we're in the ocamldebug buffer), and the `current' module
name is the filename stripped of any *.ml* suffixes (this assumes the
usual correspondence between module and file naming is observed). The
`current' position is that of the current buffer (if we're in a source
file) or the position of the last break or step (if we're in the
ocamldebug buffer).
If ARG is present, it overrides any FMT flags and its string
representation is simply concatenated with the COMMAND."
;; Make sure debugger buffer is displayed in a window.
(ocamldebug-set-buffer)
(message "Command: %s" (ocamldebug-call-1 command fmt arg)))
(defun ocamldebug-call-1 (command &optional fmt arg)
;; Record info on the last prompt in the buffer and its position.
(with-current-buffer ocamldebug-current-buffer
(save-excursion
(goto-char (process-mark (get-buffer-process ocamldebug-current-buffer)))
(beginning-of-line)
(when (looking-at comint-prompt-regexp)
(set-marker ocamldebug-delete-prompt-marker (point)))))
(let ((cmd (cond
(arg (concat command " " (int-to-string arg)))
(fmt (ocamldebug-format-command
(concat command " " fmt)))
(command))))
(process-send-string (get-buffer-process ocamldebug-current-buffer)
(concat cmd "\n"))
cmd))
(provide 'ocamldebug)
;;; ocamldebug.el ends here
tuareg-3.0.1/sample_eval.ml 0000664 0000000 0000000 00000000704 14315315656 0015636 0 ustar 00root root 0000000 0000000 (* Test evaluation (C-cC-e). *)
let a = 1 let b = 2 (* Try with cursor on second let *)
let c = 1 (* comment *) let d = 2
let e = 1 + (* cursor → *) 2
let f = 2 (* cursor after the comment → f *)
let g = 1;;
(* Test with cursor on this line → g *)
(* Test with cursor on this line → g *)
let h = 1;;
(* Force new phrase after this comment *);;
(* Evaluating on this line sends an empty phrase (refused) *)
let not_well_braced = (1
tuareg-3.0.1/sample_highlight.ml 0000664 0000000 0000000 00000016460 14315315656 0016664 0 ustar 00root root 0000000 0000000 type 'a t = Int : int t | String : string t
let trois : type a . a t -> a = f
type a
type 'a t
type 'al t
type 'al'l t
type +'b u
type ('a, 'b) t
type (+'a, 'b) t
type t =
| A
type t +=
| A
type t =
{ first: A.t; (* and *)
second: B.t;
third: C.t }
(* FAIL sprintf (but if one change the line it get well re-highlighted) *)
(* Probably an effect of [let ...] *)
let html_date_of_post p =
match p.date with
| None -> []
| Some d ->
let date =
let open Syndic.Date in
let open! Infix in
sprintf "%s %02d, %d" (string_of_month(month d)) (day d) (year d) in
[`Data date]
let (x: t) = expr
let (x:t) = expr
let (x: t list) = exp
let (x:t list) = 1
let x : t = expr
let x, (yyy: t) = 1
let (x, y) = A.f ()
let x, y = A.f ()
let x, y, z = A.f ()
let (x, y), z = A.f ()
let (x: y :> u) = 1
let x as y = 1
let (x,y) as z = (1,2)
let X x = A.f ()
let X(x) = A.f ()
let `X x = A.f ()
let A.X x, A.Y (y:t) = f()
let A.X x, (`Y y:t) = f()
let X(x, y) = A.f ()
let X (x, y) = A.f ()
let A.X(x, y, z) = A.f ()
let A.X x = A.f ()
let x : ('a, 'b) t = A.f ()
let x = (x : X.t)
let x = (val X : X.t)
let m = __MODULE__
let typecheck ast = ast_starts_with_as
let _ = (x :: not_a_type)
let _ = (x : 'a t)
let _ = (x :> t)
let _ = (let x : t = 1 in x) (* not a type *)
let _ = (1 + let x : t = 1 in x)
let _ = (1 + 1 : int)
let _ = (z : Map.t)
let _ = (z x : Map.t)
let _ = (z x : _ Map.t)
let _ = (z x : ('a, int) Map.t)
let _ = {first = x; second = y; third = z}
let () =
printf "(v:t) in strings (expected: %g" n; printf ")"
let x = ref 1
let f x = ignore(x+1)
let f ref c = 1
let f (x, (y, z)) = 1
let (x, (y, z)) = 1
let ((x, y): t) = 1
let f () = 1
let f (type t) x = 1
let f (module M: T) = M.f
let _ = f (module M)
let x = A.b
let z = (compare (x: int) (1 + y: int) : t)
let f x = A.B.c
let f x
y = 3
let f = fun x -> 4
let f = function x -> 1
let f x y z : t = 2
let f (x,y) z : t = 2
let f (x: t) (y: ('a, (a, int)) t) = 2
let f ~x y = 3
let f ~x ?(y=2) = 3
let f (X x) y = 1
let f = fun (x: int) u (y,z) -> 4
let f = fun (x: int) u
(y,z) -> 1
let f (x: int) u
(y,z) = 1
let f = fun ?(x=y-1) z -> 1
let f = fun ?(x=true) z -> 1
let f = fun ?(x=1=1) z -> "two type of '=' in option 'x'"
let f x = fun u v (u,c) ?(u=v-1) ~(e: int) -> 1
let f = fun x u->1
let f u0 ~s:a s = "s: does not introduce a type"
let f u0 ~s:(a,b) s = "s: does not introduce a type"
let f x : ret = body
let f (x) : ret = body
let f ?x:(y = 1) ?(y = (x: t)) = body
let f ?x:(y = 1) ?(y = (x: t)) : ret = body
let f ?x:(y = expr + 1) (y: t) ~z:u : ret = body
let f ?x:(y = (expr + 1)) (y: t) ?z:t : ret = body
let x = call ~l:(fun x -> y = z)
let f {first; second; third} = body
let f ({first; second; third} as all) = body
let f a {first; second; third} b = body
let f a ({first; second; third} as all) b = body
let f a ({first = x; second = y; third} as all) b = body
let f a [x; y; z] u = body
let f (type a) x (type b) y = body
let f (A(x:t), B x, {z = s; p = Q e}) = body
let f' u =
(* function *)
if u.low >= 0. then f'_pos u.low u.high
let f' u =
(* fun *)
if u.low >= 0. then f'_pos u.low u.high
let rec f (A(x:t), B x, {z = s; p = Q e}) = body
(* Labels, type annotations, and operators *)
let _ =
f ~foo:x;
(f ~foo:x);
(f ~foo:x y);
(grault ~garply:(x));
let x = 1 + 3 / 2 in
I.(1 +:2);
I.(1 +: 2);
K.(x |+ y ?: z);
(expr ~- expr : ty);
(expr ~label : ty)
let andfoo = 1.
let[@x] andfoo = 1.
and+ andfoo = 2
let valfoo = 1
let x = 1 [@@@x rzfhjoi[x]]
let x = 1 [@@x "payload"]
let z = [%%foo let x = 2 in x + 1]
let[@foo] x = 2 in x + 1
let%m[@foo] x = 2 in x + 1
let _ = begin[@foo][@bar x] ... end
module[@foo] M = struct end
type[@foo] t = T
type%foo[@foo] nonrec t = t
let x = first ;%x second
let%xx x = 1
let%xx f x = 1
let%x f x = 1
let%foo x = 2 in x + 1
let x = begin%foo ... end
val%foo f : t -> t
val%foo[@bar] f : t -> t
module%foo Mo = struct end
module%foo type Mo = struct%loo[@bah] end
[%%foo module M = struct end ]
val%foo f : t -> t
let f = fun%foo x -> x + 1
let f = fun%foo[@bar] x -> x + 1
let f = fun[@bar] x -> x + 1
let f = function%foo[@bar] x -> x + 1
let content = [%html{|some content
|}]
let svgpath = [%svg{||}]
let my_text =
[%html
{|This is an HTML formated content.|}]
let my_span = Html.(span ~a:[a_class ["mytext"]] my_text)
let%html content = {|some content
|}
let my_head = [%html "" my_title ""]
let x = `failwith (* Constructor, not builtin *)
let y = `Not_found (* Constructor, not builtin *)
(* FIXME: not a type*)
let _ = (Jacobi.jacobi n ~alpha:nu ~beta:nu x)**3.
open A.B
open! A.B
module X = Y
module rec X = struct end
module rec A.B (* path not allowed *)
module type x (* lowercase allowed! *)
(* with type t open! mutable virtual *)
module type X = Y with module Z = A
module type X = Y with module Z.U = A
and module A = B.C
module type X = Y with type t = u
and type u = l
module A = B.C
module A = B.C(String)
module A = B.C(U(V).T)
module A = B.C(U(V))
module A : E = B.C(U(V))
module A : B.C(String).T = A
module F(A : Y) = T
module F(A: X.Y) = T
module F(A : X.t) = T
module F(A : X(Y).T) = T
module F(A : X(Y(Z)).T) = A
module F(A : A1)(B:B1) = Z
module F = functor (A: A1) -> functor(B:B1) -> A.B.f
let module X = F(G) in ()
include Make (* make sure the coloring does not extend on spaces *)
include Make(IO)
include (Make(IO) : module type of Make(IO) with type t := t)
include Make(IO).T (* in a module sig *)
module Make_client
(IO:S.IO with type 'a t = 'a Lwt.t)
(Request:Request with module IO = IO)
(Response:Response with module IO = IO)
(Net:Net with module IO = IO) = struct end
class printable_point x_init =
object (s)
val mutable x = x_init
method get_x = x
method move d = x <- x + d
method print = print_int s#get_x
end;;
class virtual abstract_point x_init =
object (self)
method virtual get_x : int
method get_offset = self#get_x - x_init
method! virtual move : int -> unit
method private virtual x = body
method virtual private y = body
end;;
class ['a] re x_init = object
val mutable x = (x_init : 'a)
method get = x
method set y = x <- y
end;;
class type c2 = object ('a) method m : 'a end;;
class type c2 = object (_) method m : 'a end;;
class type virtual c2 = object ('a) method m : 'a end;;
class xx x y z = object
method x yellow
zero = 1
method virtual x ?(y=1) t = 1
method virtual private x (y:t) z = 1
method private x y z = body
method private x y z : t = body
method private virtual x y z
method x private x = 1
end
val x
val! x
val mutable x
val mutable virtual x
val virtual x
val virtual mutable x
val mutable
val f : int -> 'a t
class virtual x = object
method virtual x : int -> float
end;;
class x = object
method virtual x : int -> float
end;;
class ['a] x ~ne (z: y) = object
method virtual x : int -> float
end;;
object(self) end;;
object (self) end;;
object(self : ('a) t) end;;
object (self : ('a, 'b) t) end;;
external f
let x = if x then y else z
exception E of string
let _ = failwithf {| message |}
let z = .< x + 1 .>
;;
module type T = sig
val f : t -> t -> t
end
;;
(* Local Variables: *)
(* End: *)
(* tuareg-support-metaocaml: t *)
tuareg-3.0.1/tuareg-compat.el 0000664 0000000 0000000 00000037761 14315315656 0016123 0 ustar 00root root 0000000 0000000 ;;; tuareg-compat.el -*- lexical-binding:t -*-
;; FIX: make sure `comment-region' supports `comment-continue' made
;; only of spaces (and in a consistent fashion even for older Emacs).
(require 'newcomment)
;; Emacs < 26
(defun tuareg--comment-padright--advice (orig-fun &rest args)
(let ((str (nth 0 args)))
(unless (and (eq major-mode 'tuareg-mode)
(stringp str) (not (string-match "\\S-" str)))
(apply orig-fun args))))
(when (and (< emacs-major-version 26) (fboundp 'comment-region-default))
(advice-add 'comment-padright :around #'tuareg--comment-padright--advice))
;; Emacs < 27
(defun tuareg--comment-region-default (beg end &optional arg)
(let* ((numarg (prefix-numeric-value arg))
(style (cdr (assoc comment-style comment-styles)))
(lines (nth 2 style))
(block (nth 1 style))
(multi (nth 0 style)))
;; We use `chars' instead of `syntax' because `\n' might be
;; of end-comment syntax rather than of whitespace syntax.
;; sanitize BEG and END
(goto-char beg) (skip-chars-forward " \t\n\r") (beginning-of-line)
(setq beg (max beg (point)))
(goto-char end) (skip-chars-backward " \t\n\r") (end-of-line)
(setq end (min end (point)))
(if (>= beg end) (error "Nothing to comment"))
;; sanitize LINES
(setq lines
(and
lines ;; multi
(progn (goto-char beg) (beginning-of-line)
(skip-syntax-forward " ")
(>= (point) beg))
(progn (goto-char end) (end-of-line) (skip-syntax-backward " ")
(<= (point) end))
(or block (not (string= "" comment-end)))
(or block (progn (goto-char beg) (re-search-forward "$" end t)))))
;; don't add end-markers just because the user asked for `block'
(unless (or lines (string= "" comment-end)) (setq block nil))
(cond
((consp arg) (uncomment-region beg end))
((< numarg 0) (uncomment-region beg end (- numarg)))
(t
(let ((multi-char (/= (string-match "[ \t]*\\'" comment-start) 1))
indent triple)
(if (eq (nth 3 style) 'multi-char)
(save-excursion
(goto-char beg)
(setq indent multi-char
;; Triple if we will put the comment starter at the margin
;; and the first line of the region isn't indented
;; at least two spaces.
triple (and (not multi-char) (looking-at "\t\\| "))))
(setq indent (nth 3 style)))
;; In Lisp and similar modes with one-character comment starters,
;; double it by default if `comment-add' says so.
;; If it isn't indented, triple it.
(if (and (null arg) (not multi-char))
(setq numarg (* comment-add (if triple 2 1)))
(setq numarg (1- (prefix-numeric-value arg))))
(comment-region-internal
beg end
(let ((s (comment-padright comment-start numarg)))
(if (string-match comment-start-skip s) s
(comment-padright comment-start)))
(let ((s (comment-padleft comment-end numarg)))
(and s (if (string-match comment-end-skip s) s
(comment-padright comment-end))))
(if multi (or (comment-padright comment-continue numarg)
(and (stringp comment-continue) comment-continue)))
(if multi
(comment-padleft (comment-string-reverse comment-continue) numarg))
block
lines
indent))))))
(defun tuareg--comment-region-default--advice (orig-fun &rest args)
(apply (if (eq major-mode 'tuareg-mode)
'tuareg--comment-region-default
orig-fun)
args))
(when (and (< emacs-major-version 27) (fboundp 'comment-region-default))
(advice-add 'comment-region-default :around
#'tuareg--comment-region-default--advice))
;; Emacs 27
(defun tuareg--comment-region-default-1 (beg end &optional arg noadjust)
"Comment region between BEG and END.
See `comment-region' for ARG. If NOADJUST, do not skip past
leading/trailing space when determining the region to comment
out."
(let* ((numarg (prefix-numeric-value arg))
(style (cdr (assoc comment-style comment-styles)))
(lines (nth 2 style))
(block (nth 1 style))
(multi (nth 0 style)))
(if noadjust
(when (bolp)
(setq end (1- end)))
;; We use `chars' instead of `syntax' because `\n' might be
;; of end-comment syntax rather than of whitespace syntax.
;; sanitize BEG and END
(goto-char beg)
(skip-chars-forward " \t\n\r")
(beginning-of-line)
(setq beg (max beg (point)))
(goto-char end)
(skip-chars-backward " \t\n\r")
(end-of-line)
(setq end (min end (point)))
(when (>= beg end)
(error "Nothing to comment")))
;; sanitize LINES
(setq lines
(and
lines ;; multi
(progn (goto-char beg) (beginning-of-line)
(skip-syntax-forward " ")
(>= (point) beg))
(progn (goto-char end) (end-of-line) (skip-syntax-backward " ")
(<= (point) end))
(or block (not (string= "" comment-end)))
(or block (progn (goto-char beg) (re-search-forward "$" end t)))))
;; don't add end-markers just because the user asked for `block'
(unless (or lines (string= "" comment-end)) (setq block nil))
(cond
((consp arg) (uncomment-region beg end))
((< numarg 0) (uncomment-region beg end (- numarg)))
(t
(let ((multi-char (/= (string-match "[ \t]*\\'" comment-start) 1))
indent triple)
(if (eq (nth 3 style) 'multi-char)
(save-excursion
(goto-char beg)
(setq indent multi-char
;; Triple if we will put the comment starter at the margin
;; and the first line of the region isn't indented
;; at least two spaces.
triple (and (not multi-char) (looking-at "\t\\| "))))
(setq indent (nth 3 style)))
;; In Lisp and similar modes with one-character comment starters,
;; double it by default if `comment-add' says so.
;; If it isn't indented, triple it.
(if (and (null arg) (not multi-char))
(setq numarg (* comment-add (if triple 2 1)))
(setq numarg (1- (prefix-numeric-value arg))))
(comment-region-internal
beg end
(let ((s (comment-padright comment-start numarg)))
(if (string-match comment-start-skip s) s
(comment-padright comment-start)))
(let ((s (comment-padleft comment-end numarg)))
(and s (if (string-match comment-end-skip s) s
(comment-padright comment-end))))
(if multi
(or (comment-padright comment-continue numarg)
;; `comment-padright' returns nil when
;; `comment-continue' contains only whitespace
(and (stringp comment-continue) comment-continue)))
(if multi
(comment-padleft (comment-string-reverse comment-continue) numarg))
block
lines
indent))))))
(defun tuareg--comment-region-default-1--advice (orig-fun &rest args)
(apply (if (eq major-mode 'tuareg-mode)
'tuareg--comment-region-default-1
orig-fun)
args))
(when (and (= emacs-major-version 27) (fboundp 'comment-region-default-1))
(advice-add 'comment-region-default-1 :around
#'tuareg--comment-region-default-1--advice))
;; FIX: uncommenting
;; Emacs < 27
(defun tuareg--uncomment-region-default (beg end &optional arg)
"Uncomment each line in the BEG .. END region.
The numeric prefix ARG can specify a number of chars to remove from the
comment delimiters.
This function is the default value of `uncomment-region-function'."
(goto-char beg)
(setq end (copy-marker end))
(let* ((numarg (prefix-numeric-value arg))
(ccs comment-continue)
(srei (or (comment-padright ccs 're)
(and (stringp comment-continue) comment-continue)))
(csre (comment-padright comment-start 're))
(sre (and srei (concat "^\\s-*?\\(" srei "\\)")))
spt)
(while (and (< (point) end)
(setq spt (comment-search-forward end t)))
(let ((ipt (point))
;; Find the end of the comment.
(ept (progn
(goto-char spt)
(unless (or (comment-forward)
;; Allow non-terminated comments.
(eobp))
(error "Can't find the comment end"))
(point)))
(box nil)
(box-equal nil)) ;Whether we might be using `=' for boxes.
(save-restriction
(narrow-to-region spt ept)
;; Remove the comment-start.
(goto-char ipt)
(skip-syntax-backward " ")
;; A box-comment starts with a looong comment-start marker.
(when (and (or (and (= (- (point) (point-min)) 1)
(setq box-equal t)
(looking-at "=\\{7\\}")
(not (eq (char-before (point-max)) ?\n))
(skip-chars-forward "="))
(> (- (point) (point-min) (length comment-start)) 7))
(> (count-lines (point-min) (point-max)) 2))
(setq box t))
;; Skip the padding. Padding can come from comment-padding and/or
;; from comment-start, so we first check comment-start.
(if (or (save-excursion (goto-char (point-min)) (looking-at csre))
(looking-at (regexp-quote comment-padding)))
(goto-char (match-end 0)))
(when (and sre (looking-at (concat "\\s-*\n\\s-*" srei)))
(goto-char (match-end 0)))
(if (null arg) (delete-region (point-min) (point))
(let ((opoint (point-marker)))
(skip-syntax-backward " ")
(delete-char (- numarg))
(unless (and (not (bobp))
(save-excursion (goto-char (point-min))
(looking-at comment-start-skip)))
;; If there's something left but it doesn't look like
;; a comment-start any more, just remove it.
(delete-region (point-min) opoint))))
;; Remove the end-comment (and leading padding and such).
(goto-char (point-max)) (comment-enter-backward)
;; Check for special `=' used sometimes in comment-box.
(when (and box-equal (not (eq (char-before (point-max)) ?\n)))
(let ((pos (point)))
;; skip `=' but only if there are at least 7.
(when (> (skip-chars-backward "=") -7) (goto-char pos))))
(unless (looking-at "\\(\n\\|\\s-\\)*\\'")
(when (and (bolp) (not (bobp))) (backward-char))
(if (null arg) (delete-region (point) (point-max))
(skip-syntax-forward " ")
(delete-char numarg)
(unless (or (eobp) (looking-at comment-end-skip))
;; If there's something left but it doesn't look like
;; a comment-end any more, just remove it.
(delete-region (point) (point-max)))))
;; Unquote any nested end-comment.
(comment-quote-nested comment-start comment-end t)
;; Eliminate continuation markers as well.
(when sre
(let* ((cce (comment-string-reverse (or comment-continue
comment-start)))
(erei (and box (comment-padleft cce 're)))
(ere (and erei (concat "\\(" erei "\\)\\s-*$"))))
(goto-char (point-min))
(while (progn
(if (and ere (re-search-forward
ere (line-end-position) t))
(replace-match "" t t nil (if (match-end 2) 2 1))
(setq ere nil))
(forward-line 1)
(re-search-forward sre (line-end-position) t))
(replace-match "" t t nil (if (match-end 2) 2 1)))))
;; Go to the end for the next comment.
(goto-char (point-max))))))
(set-marker end nil))
(defun tuareg--uncomment-region-default--advice (orig-fun &rest args)
(apply (if (eq major-mode 'tuareg-mode)
'tuareg--uncomment-region-default
orig-fun)
args))
(when (and (< emacs-major-version 27) (fboundp 'uncomment-region-default))
(advice-add 'uncomment-region-default :around
#'tuareg--uncomment-region-default--advice))
;; Emacs 27
(defun tuareg--uncomment-region-default-1 (beg end &optional arg)
"Uncomment each line in the BEG .. END region.
The numeric prefix ARG can specify a number of chars to remove from the
comment delimiters.
This function is the default value of `uncomment-region-function'."
(goto-char beg)
(setq end (copy-marker end))
(let* ((numarg (prefix-numeric-value arg))
(ccs comment-continue)
(srei (or (comment-padright ccs 're)
(and (stringp comment-continue) comment-continue)))
(csre (comment-padright comment-start 're))
(sre (and srei (concat "^\\s-*?\\(" srei "\\)")))
spt)
(while (and (< (point) end)
(setq spt (comment-search-forward end t)))
(let ((ipt (point))
;; Find the end of the comment.
(ept (progn
(goto-char spt)
(unless (or (comment-forward)
;; Allow non-terminated comments.
(eobp))
(error "Can't find the comment end"))
(point)))
(box nil)
(box-equal nil)) ;Whether we might be using `=' for boxes.
(save-restriction
(narrow-to-region spt ept)
;; Remove the comment-start.
(goto-char ipt)
(skip-syntax-backward " ")
;; A box-comment starts with a looong comment-start marker.
(when (and (or (and (= (- (point) (point-min)) 1)
(setq box-equal t)
(looking-at "=\\{7\\}")
(not (eq (char-before (point-max)) ?\n))
(skip-chars-forward "="))
(> (- (point) (point-min) (length comment-start)) 7))
(> (count-lines (point-min) (point-max)) 2))
(setq box t))
;; Skip the padding. Padding can come from comment-padding and/or
;; from comment-start, so we first check comment-start.
(if (or (save-excursion (goto-char (point-min)) (looking-at csre))
(looking-at (regexp-quote comment-padding)))
(goto-char (match-end 0)))
(when (and sre (looking-at (concat "\\s-*\n\\s-*" srei)))
(goto-char (match-end 0)))
(if (null arg) (delete-region (point-min) (point))
(let ((opoint (point-marker)))
(skip-syntax-backward " ")
(delete-char (- numarg))
(unless (and (not (bobp))
(save-excursion (goto-char (point-min))
(looking-at comment-start-skip)))
;; If there's something left but it doesn't look like
;; a comment-start any more, just remove it.
(delete-region (point-min) opoint))))
;; Remove the end-comment (and leading padding and such).
(goto-char (point-max)) (comment-enter-backward)
;; Check for special `=' used sometimes in comment-box.
(when (and box-equal (not (eq (char-before (point-max)) ?\n)))
(let ((pos (point)))
;; skip `=' but only if there are at least 7.
(when (> (skip-chars-backward "=") -7) (goto-char pos))))
(unless (looking-at "\\(\n\\|\\s-\\)*\\'")
(when (and (bolp) (not (bobp))) (backward-char))
(if (null arg) (delete-region (point) (point-max))
(skip-syntax-forward " ")
(delete-char numarg)
(unless (or (eobp) (looking-at comment-end-skip))
;; If there's something left but it doesn't look like
;; a comment-end any more, just remove it.
(delete-region (point) (point-max)))))
;; Unquote any nested end-comment.
(comment-quote-nested comment-start comment-end t)
;; Eliminate continuation markers as well.
(when sre
(let* ((cce (comment-string-reverse (or comment-continue
comment-start)))
(erei (and box (comment-padleft cce 're)))
(ere (and erei (concat "\\(" erei "\\)\\s-*$"))))
(goto-char (point-min))
(while (progn
(if (and ere (re-search-forward
ere (line-end-position) t))
(replace-match "" t t nil (if (match-end 2) 2 1))
(setq ere nil))
(forward-line 1)
(re-search-forward sre (line-end-position) t))
(replace-match "" t t nil (if (match-end 2) 2 1)))))
;; Go to the end for the next comment.
(goto-char (point-max)))
;; Remove any obtrusive spaces left preceding a tab at `spt'.
(when (and (eq (char-after spt) ?\t) (eq (char-before spt) ? )
(> tab-width 0))
(save-excursion
(goto-char spt)
(let* ((fcol (current-column))
(slim (- (point) (mod fcol tab-width))))
(delete-char (- (skip-chars-backward " " slim)))))))))
(set-marker end nil))
(defun tuareg--uncomment-region-default-1--advice (orig-fun &rest args)
(apply (if (eq major-mode 'tuareg-mode)
'tuareg--uncomment-region-default-1
orig-fun)
args))
(when (and (<= emacs-major-version 28) (fboundp 'uncomment-region-default-1))
(advice-add 'uncomment-region-default-1 :around
#'tuareg--uncomment-region-default-1--advice))
(provide 'tuareg-compat)
tuareg-3.0.1/tuareg-menhir.el 0000664 0000000 0000000 00000010266 14315315656 0016111 0 ustar 00root root 0000000 0000000 ;;; tuareg-menhir.el --- Support for Menhir (and Ocamlyacc) source code -*- lexical-binding: t; -*-
;; Copyright (C) 2017 Free Software Foundation, Inc
;; Author: Stefan Monnier
;; Keywords:
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Commentary:
;; Major mode to edit Menhir (and Ocamlyacc) source files.
;; Currently provides:
;; - Font-lock highlighting
;; - Automatic indentation
;; - Imenu
;;; Code:
(require 'cl-lib)
(require 'tuareg)
(defgroup tuareg-menhir ()
"Major mode to edit Menhir source files."
:group 'tuareg)
(defvar tuareg-menhir-mode-syntax-table
(let ((st (make-syntax-table tuareg-mode-syntax-table)))
;; Menhir comments are hellish: can be C, C++, or OCaml style!
;; FIXME: C/C++ style comments aren't allowed inside the OCaml part of the code.
(modify-syntax-entry ?/ ". 124b" st)
(modify-syntax-entry ?\n "> b" st)
st))
(defun tuareg-menhir--in-ocaml-p ()
"Return non-nil if point is within OCaml code."
(let ((pos (car (nth 9 (syntax-ppss)))))
(and pos (eq ?\{ (char-after pos)))))
(defconst tuareg-menhir--keywords
'("parameter" "token" "nonassoc" "left" "right" "type" "start" "on_error_reduce"))
;;;; Indentation
(defcustom tuareg-menhir-basic-indent 2
"Default basic indentation step for Menhir files."
:type 'integer)
(defcustom tuareg-menhir-rule-indent tuareg-menhir-basic-indent
"Indentation column of rules."
:type 'integer)
(defcustom tuareg-menhir-action-indent tuareg-menhir-basic-indent
"Indentation action w.r.t rules."
:type 'integer)
(defun tuareg-menhir--indent-column ()
(save-excursion
(beginning-of-line)
(skip-chars-forward " \t")
(cond
((looking-at "\\(?:\\sw\\|\\s_\\)+:") 0)
((looking-at "|") tuareg-menhir-rule-indent)
((looking-at "{")
(+ tuareg-menhir-rule-indent tuareg-menhir-action-indent))
(t 0))))
(defun tuareg-menhir--indent-ocaml ()
(let ((smie-rules-function #'tuareg-smie-rules)
(smie-grammar tuareg-smie-grammar)
(smie-forward-token-function #'tuareg-smie-forward-token)
(smie-backward-token-function #'tuareg-smie-backward-token))
(smie-indent-line)))
(defun tuareg-menhir--indent (&optional _)
(if (save-excursion (beginning-of-line)
(tuareg-menhir--in-ocaml-p))
(tuareg-menhir--indent-ocaml)
(let ((col (tuareg-menhir--indent-column)))
(if (save-excursion (skip-chars-backward " \t") (bolp))
(indent-line-to col)
(save-excursion (indent-line-to col))))))
;;;; Font-lock
(defvar tuareg-menhir-font-lock-keywords
`(("^\\(\\(?:\\sw\\|\\s_\\)+\\):" (1 font-lock-function-name-face))
(,(concat "^%\\(?:%\\|" (regexp-opt tuareg-menhir--keywords) "\\_>\\)")
(0 font-lock-builtin-face))
("%\\(?:prec\\|public\\|inline\\)\\_>"
(0 (unless (tuareg-menhir--in-ocaml-p) font-lock-builtin-face)))))
;;;; Imenu
(defvar tuareg-menhir-imenu-generic-expression
'((nil "^\\(\\(?:\\sw\\|\\s_\\)+\\):" 1)))
;;;###autoload
(add-to-list 'auto-mode-alist '("\\.mly\\'" . tuareg-menhir-mode))
;;;###autoload
(define-derived-mode tuareg-menhir-mode prog-mode "Menhir"
"Major mode to edit Menhir (and Ocamlyacc) files."
(setq-local indent-line-function #'tuareg-menhir--indent)
(setq-local comment-start "/* ")
(setq-local comment-end " */")
(setq-local comment-start-skip "\\(?:[(/]\\*+\\|//+\\)[ \t]*")
(setq-local comment-end-skip "[ \t]*\\(?:\\*+[/)]\\)?")
(setq-local font-lock-defaults '(tuareg-menhir-font-lock-keywords))
(setq-local imenu-generic-expression tuareg-menhir-imenu-generic-expression)
)
(provide 'tuareg-menhir)
;;; tuareg-menhir.el ends here
tuareg-3.0.1/tuareg-opam.el 0000664 0000000 0000000 00000036305 14315315656 0015565 0 ustar 00root root 0000000 0000000 ;;; tuareg-opam.el --- Mode for editing opam files -*- coding: utf-8; lexical-binding:t -*-
;; Copyright (C) 2017- Christophe Troestler
;; This file is not part of GNU Emacs.
;; Permission to use, copy, modify, and distribute this software for
;; any purpose with or without fee is hereby granted, provided that
;; the above copyright notice and this permission notice appear in
;; all copies.
;;
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
;; LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
(defvar tuareg-opam-mode-hook nil)
(defvar tuareg-opam-indent-basic 2
"The default amount of indentation.")
(defvar tuareg-opam-flymake nil
"It t, use flymake to lint OPAM files.")
(defvar tuareg-opam-mode-map
(let ((map (make-keymap)))
(define-key map "\C-j" #'newline-and-indent)
map)
"Keymap for tuareg-opam mode")
(defgroup tuareg-opam nil
"Support for the OPAM files."
:group 'languages)
;; TODO this is wrong, and doesn't respect OPAMROOT. It should probably just
;; removed.
(defconst tuareg-opam-compilers
(when (file-directory-p "~/.opam")
(let ((c (directory-files "~/.opam" t "[0-9]+\\.[0-9]+\\.[0-9]+")))
(if (file-directory-p "~/.opam/system")
(cons "~/.opam/system" c)
c)))
"The list of OPAM directories for the installed compilers.")
(defvar tuareg-opam
(let ((opam (executable-find "opam")))
(if opam opam
(let ((opam (locate-file "bin/opam" tuareg-opam-compilers)))
(if (and opam (file-executable-p opam)) opam)))) ; or nil
"The full path of the opam executable or `nil' if opam wasn't found.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Syntax highlighting
(defface tuareg-opam-error-face
'((t (:inherit error)))
"Face for constructs considered as errors (e.g. deprecated constructs).")
(defvar tuareg-opam-error-face 'tuareg-opam-error-face
"Face for constructs considered as errors (e.g. deprecated constructs).")
(defface tuareg-opam-pkg-variable-name-face
'((t (:inherit font-lock-variable-name-face :slant italic)))
"Face for package specific variables.")
(defvar tuareg-opam-pkg-variable-name-face 'tuareg-opam-pkg-variable-name-face
"Face for package specific variables.")
(defconst tuareg-opam-keywords
'("opam-version" "name" "version" "maintainer" "authors"
"license" "homepage" "doc" "bug-reports" "dev-repo"
"tags" "patches" "substs" "build" "install" "run-test"
"remove" "depends" "depopts" "conflicts" "conflict-class"
"depexts" "messages" "post-messages" "available"
"flags" "features" "synopsis" "description" "url" "setenv"
"build-env" "extra-files" "pin-depends")
"Kewords in OPAM files.")
(defconst tuareg-opam-keywords-regex
(regexp-opt tuareg-opam-keywords 'symbols))
(defconst tuareg-opam-variables-regex
(regexp-opt '("opam-version" "root" "jobs" "make" "arch"
"os" "os-distribution" "os-family" "os-version"
"switch" "prefix" "lib" "bin" "sbin" "share" "doc"
"etc" "man" "toplevel" "stublibs" "user" "group"
"name" "version" "pinned")
'symbols)
"Variables declared in OPAM.")
(defconst tuareg-opam-pkg-variables-regex
(regexp-opt '("name" "version" "depends" "installed" "enable" "pinned"
"bin" "sbin" "lib" "man" "doc" "share" "etc" "build"
"hash" "dev" "build-id")
'symbols)
"Package variables in OPAM.")
(defconst tuareg-opam-scopes-regex
(regexp-opt '("build" "with-test" "with-doc"
"pinned"
"true" "false")
'symbols)
"Package scopes")
(defconst tuareg-opam-deprecated-regex
(eval-when-compile (regexp-opt '("build-test" "build-doc") 'symbols)))
(defvar tuareg-opam-font-lock-keywords
`((,tuareg-opam-deprecated-regex . tuareg-opam-error-face)
(,(concat "^" tuareg-opam-keywords-regex ":")
1 font-lock-keyword-face)
("^\\(extra-source\\)\\_>" 1 font-lock-keyword-face)
(,(concat "^\\(x-[[:alnum:]]+\\):")
1 font-lock-keyword-face)
(,tuareg-opam-scopes-regex . font-lock-constant-face)
(,tuareg-opam-variables-regex . font-lock-variable-name-face)
(,(concat "%{" tuareg-opam-variables-regex "\\(?:}%\\|\\?\\)")
(1 font-lock-variable-name-face t))
(,(concat "%{\\([a-zA-Z_][a-zA-Z0-9_+-]*\\):"
tuareg-opam-pkg-variables-regex "\\(?:}%\\|\\?\\)")
(1 font-lock-type-face t)
(2 font-lock-variable-name-face t t))
(,(concat "%{\\([a-zA-Z_][a-zA-Z0-9_+-]*\\):"
"\\([a-zA-Z][a-zA-Z0-9_+-]*\\)\\(?:}%\\|\\?\\)")
(1 font-lock-type-face t)
(2 tuareg-opam-pkg-variable-name-face t t))
;; "package-name:var-name" anywhere (do not force)
(,(concat "\\_<\\([a-zA-Z_][a-zA-Z0-9_+-]*\\):"
tuareg-opam-pkg-variables-regex)
(1 font-lock-type-face)
(2 font-lock-variable-name-face))
("\\_<\\([a-zA-Z_][a-zA-Z0-9_+-]*\\):\\([a-zA-Z][a-zA-Z0-9_+-]*\\)\\_>"
(1 font-lock-type-face)
(2 tuareg-opam-pkg-variable-name-face)))
"Highlighting for OPAM files")
(defvar tuareg-opam-prettify-symbols
`(("&" . ,(decode-char 'ucs 8743)); 'LOGICAL AND' (U+2227)
("|" . ,(decode-char 'ucs 8744)); 'LOGICAL OR' (U+2228)
("<=" . ,(decode-char 'ucs 8804))
(">=" . ,(decode-char 'ucs 8805))
("!=" . ,(decode-char 'ucs 8800)))
"Alist of symbol prettifications for OPAM files.
See `prettify-symbols-alist' for more information.")
(defvar tuareg-opam-mode-syntax-table
(let ((table (make-syntax-table)))
(modify-syntax-entry ?# "< b" table)
(modify-syntax-entry ?\n "> b" table)
(modify-syntax-entry ?\( "()" table)
(modify-syntax-entry ?\) ")(" table)
(modify-syntax-entry ?\{ "(}" table)
(modify-syntax-entry ?\} "){" table)
(modify-syntax-entry ?\[ "(]" table)
(modify-syntax-entry ?\] ")[" table)
table)
"Tuareg-opam syntax table.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; SMIE
(require 'smie)
(defvar tuareg-opam-smie-grammar
(let* ((decl-of-kw (lambda(kw) `(decls ,kw ":" list)))
(bnfprec2
(smie-bnf->prec2
`((decls . ,(mapcar decl-of-kw tuareg-opam-keywords) )
(list ("[" list "]")
(value))
(value (string "{" filter "}")
(string))
(string)
(filter)))))
(smie-prec2->grammar
(smie-merge-prec2s
bnfprec2
(smie-precs->prec2
'((right "&" "|")
(left "=" "!=" ">" ">=" "<" "<=")))
))))
(defun tuareg-opam-smie-rules (kind token)
(cond
((and (eq kind :before) (member token tuareg-opam-keywords))
0)
((and (eq kind :before) (equal token "[") (smie-rule-hanging-p))
0)
((and (eq kind :before) (equal token "{"))
0)
(t tuareg-opam-indent-basic)))
(defvar tuareg-opam-smie-verbose-p t
"Emit context information about the current syntax state.")
(defmacro tuareg-opam-smie-debug (message &rest format-args)
`(progn
(when tuareg-opam-smie-verbose-p
(message (format ,message ,@format-args)))
nil))
(defun verbose-tuareg-opam-smie-rules (kind token)
(let ((value (tuareg-opam-smie-rules kind token)))
(tuareg-opam-smie-debug
"%s '%s'; sibling-p:%s parent:%s prev-is-[:%s hanging:%s = %s"
kind token
(ignore-errors (smie-rule-sibling-p))
(bound-and-true-p smie--parent)
(ignore-errors (smie-rule-prev-p "["))
(ignore-errors (smie-rule-hanging-p))
value)
value))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Linting
(require 'flymake)
(defalias 'tuareg-opam--flymake-proc-init-create-temp-buffer-copy
(if (fboundp 'flymake-proc-init-create-temp-buffer-copy)
'flymake-proc-init-create-temp-buffer-copy
'flymake-init-create-temp-buffer-copy))
(defalias 'tuareg-opam--proc-create-temp-inplace
(if (fboundp 'flymake-proc-create-temp-inplace)
'flymake-proc-create-temp-inplace
'flymake-create-temp-inplace))
(defun tuareg-opam-flymake-init ()
(let ((fname (tuareg-opam--flymake-proc-init-create-temp-buffer-copy
#'tuareg-opam--proc-create-temp-inplace)))
(list "opam" (list "lint" fname))))
(defvaralias 'tuareg-opam--flymake-proc-allowed-file-name-masks
(if (boundp 'flymake-proc-allowed-file-name-masks)
'flymake-proc-allowed-file-name-masks
'flymake-allowed-file-name-masks))
(defvar tuareg-opam--allowed-file-name-masks
'("[./]opam_?\\'" tuareg-opam-flymake-init)
"Flymake entry for OPAM files. See `flymake-allowed-file-name-masks'.")
(defvaralias 'tuareg-opam--flymake-proc-err-line-patterns
(if (boundp 'flymake-proc-err-line-patterns)
'flymake-proc-err-line-patterns
'flymake-err-line-patterns))
(defvar tuareg-opam--err-line-patterns
'(("File \"\\([^\"]+\\)\", line \\([0-9]+\\), \
characters \\([0-9]+\\)-\\([0-9]+\\): +\\([^\n]*\\)$"
1 2 3 5))
"Value of `flymake-proc-err-line-patterns' for OPAM files.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Skeleton
(define-skeleton tuareg-opam-insert-opam-form
"Insert a minimal opam file."
nil
"opam-version: \"2.0\"" > \n
"maintainer: \"" _ "\"" > \n
"authors: [" _ "]" > \n
"tags: [" _ "]" > \n
"license: \"" _ "\"" > \n
"homepage: \"" _ "\"" > \n
"dev-repo: \"" _ "\"" > \n
"bug-reports: \"" _ "\"" > \n
"doc: \"" _ "\"" > \n
"build: [" > \n
"[\"dune\" \"subst\" ] {pinned}" > \n
"[\"dune\" \"build\" \"-p\" name \"-j\" jobs]" > \n
"[\"dune\" \"build\" \"-p\" name \"-j\" jobs \"@doc\"] {with-doc}" > \n
"[\"dune\" \"runtest\" \"-p\" name \"-j\" jobs] {with-test}" > \n
"]" > \n
"depends: [" > \n
"\"ocaml\" {>= \"4.02\"}" > \n
"\"dune\"" > \n
"]" > \n
"synopsis: \"\"" > \n
"description: \"\"\"" > \n
"\"\"\"" > ?\n)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defvar tuareg-opam-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "\C-c.o" #'tuareg-opam-insert-opam-form)
map)
"Keymap used in Tuareg-opam mode.")
(defun tuareg-opam-build-menu ()
(easy-menu-define
tuareg-opam-mode-menu (list tuareg-opam-mode-map)
"Tuareg-opam mode menu."
'("OPAM"
["Skeleton" tuareg-opam-insert-opam-form t])))
;;;###autoload
(define-derived-mode tuareg-opam-mode prog-mode "Tuareg-opam"
"Major mode to edit opam files."
(setq font-lock-defaults '(tuareg-opam-font-lock-keywords))
(setq-local comment-start "#")
(setq-local comment-end "")
(setq-local prettify-symbols-alist tuareg-opam-prettify-symbols)
(setq indent-tabs-mode nil)
(setq-local require-final-newline mode-require-final-newline)
(smie-setup tuareg-opam-smie-grammar #'tuareg-opam-smie-rules)
;; Explicit variable declarations to avoid Emacs 24 warnings
(defvar tuareg-opam--flymake-proc-allowed-file-name-masks)
(defvar tuareg-opam--flymake-proc-err-line-patterns)
(push tuareg-opam--allowed-file-name-masks
tuareg-opam--flymake-proc-allowed-file-name-masks)
(setq-local tuareg-opam--flymake-proc-err-line-patterns
tuareg-opam--err-line-patterns)
(when (and tuareg-opam-flymake buffer-file-name)
(flymake-mode t))
(tuareg-opam-build-menu)
(run-mode-hooks 'tuareg-opam-mode-hook))
(defun tuareg-opam-config-env (&optional switch)
"Get the opam environment for the given switch (or the default
switch if none is provied) and return a list of lists of the
form (n v) where n is the name of the environment variable and v
its value (both being strings). If opam is not found or the
switch is not installed, `nil' is returned."
(let* ((switch (if switch (concat " --switch " switch)))
(get-env (concat tuareg-opam " env --sexp" switch))
(opam-env (tuareg--shell-command-to-string get-env)))
(if opam-env
(car (read-from-string opam-env)))))
(defcustom tuareg-opam-insinuate nil
"By default, Tuareg will use the environment that Emacs was
launched in. That environment may not contain an OCaml
compiler (say, because Emacs was launched graphically and the
path is set in ~/.bashrc) and will remain unchanged when one
issue an \"opam switch\" in a shell. If this variable is set to
t, Tuareg will try to use opam to set the right environment for
`compile', `run-ocaml' and `merlin-mode' based on the current
opam switch at the time the command is run (provided opam is
found). You may also use `tuareg-opam-update-env' to set the
environment for another compiler from within emacs (without
changing the opam switch). Beware that setting it to t causes
problems if you compile under tramp."
:group 'tuareg :type 'boolean)
(defun tuareg--shell-command-to-string (command)
"Similar to `shell-command-to-string', but returns nil when the
process return code is not 0 (shell-command-to-string returns the
error message as a string)."
(let* ((return-value 0)
(return-string
(with-output-to-string
(with-current-buffer standard-output
(setq return-value
(process-file shell-file-name nil '(t nil)
nil shell-command-switch command))))))
(if (= return-value 0) return-string nil)))
(defun tuareg-opam-installed-compilers ()
(let* ((cmd1 (concat tuareg-opam " switch list -i -s"))
(cmd2 (concat tuareg-opam " switch list -s")); opam2
(cpl (or (tuareg--shell-command-to-string cmd1)
(tuareg--shell-command-to-string cmd2))))
(if cpl (split-string cpl "[ \f\t\n\r\v]+" t) '())))
(defun tuareg-opam-current-compiler ()
(let* ((cmd (concat tuareg-opam " switch show -s"))
(cpl (tuareg--shell-command-to-string cmd)))
(when cpl
(replace-regexp-in-string "[ \t\n]*" "" cpl))))
;;;###autoload
(defun tuareg-opam-update-env (switch)
"Update the environment to follow current OPAM switch configuration."
(interactive
(let* ((compl (tuareg-opam-installed-compilers))
(current (tuareg-opam-current-compiler))
(default (if current current "current"))
(prompt (format "opam switch (default: %s): " default)))
(list (completing-read prompt compl))))
(let* ((switch (if (string= switch "") nil switch))
(env (tuareg-opam-config-env switch)))
(if env
(dolist (v env)
(setenv (car v) (cadr v))
(when (string= (car v) "PATH")
(setq exec-path (split-string (cadr v) path-separator))))
(message "Switch %s does not exist (or opam not found)" switch))))
;; OPAM compilation
(defun tuareg--compile-opam (&rest _)
"Advice to update the OPAM environment to sync it with the OPAM
switch before compiling."
(let* ((env (tuareg-opam-config-env)))
(when env
(setq-local compilation-environment
(mapcar (lambda(v) (concat (car v) "=" (cadr v)))
(tuareg-opam-config-env))))))
;;;###autoload
(add-to-list 'auto-mode-alist '("[./]opam_?\\'" . tuareg-opam-mode))
(provide 'tuareg-opam)
tuareg-3.0.1/tuareg-tests.el 0000664 0000000 0000000 00000074626 14315315656 0016003 0 ustar 00root root 0000000 0000000 ;;; tests for tuareg.el -*- lexical-binding: t -*-
(require 'tuareg)
(require 'compile)
(require 'ert)
(defconst tuareg-test-dir
(file-name-directory (or load-file-name buffer-file-name)))
(defun tuareg-test--remove-indentation ()
"Remove all indentation in the current buffer."
(goto-char (point-min))
(while (re-search-forward (rx bol (+ (in " \t"))) nil t)
(let ((syntax (save-match-data (syntax-ppss))))
(unless (or (nth 3 syntax) ; not in string literal
(nth 4 syntax)) ; nor in comment
(replace-match "")))))
(ert-deftest tuareg-indent-good ()
"Check indentation that we do handle satisfactorily."
(let ((file (expand-file-name "indent-test.ml" tuareg-test-dir))
(text (lambda () (buffer-substring-no-properties
(point-min) (point-max)))))
(with-temp-buffer
(insert-file-contents file)
(tuareg-mode)
(let ((orig (funcall text)))
;; Remove the indentation and check that we get the original text.
(tuareg-test--remove-indentation)
(indent-region (point-min) (point-max))
(should (equal (funcall text) orig))
;; Indent again to verify idempotency.
(indent-region (point-min) (point-max))
(should (equal (funcall text) orig))))))
(ert-deftest tuareg-indent-bad ()
"Check indentation that we do not yet handle satisfactorily."
:expected-result :failed
(let ((file (expand-file-name "indent-test-failed.ml" tuareg-test-dir))
(text (lambda () (buffer-substring-no-properties
(point-min) (point-max)))))
(with-temp-buffer
(insert-file-contents file)
(tuareg-mode)
(let ((orig (funcall text)))
;; Remove the indentation and check that we get the original text.
(tuareg-test--remove-indentation)
(indent-region (point-min) (point-max))
(should (equal (funcall text) orig))
;; Indent again to verify idempotency.
(indent-region (point-min) (point-max))
(should (equal (funcall text) orig))))))
(defmacro tuareg--lets (&rest forms)
"Execute FORMS in sequence, binding new vars as they occur.
Every expression in FORMS can be any normal ELisp expression,
with the added form (let VAR VAL) which will bind VAR to the value of VAL.
Returns the value of the last FORM."
(declare (indent 0) (debug (&rest [&or ("let" symbolp form) form])))
(let ((exps '())
(bindings '()))
(dolist (form forms)
(pcase form
(`(let ,(and (pred symbolp) var) ,val)
(push (list var (macroexp-progn (nreverse (cons val exps))))
bindings)
(setq exps '()))
(_ (push form exps))))
`(let* ,(nreverse bindings) . ,(nreverse exps))))
(ert-deftest tuareg-beginning-of-defun ()
;; Check that `beginning-of-defun' works as expected: move backwards
;; to the beginning of the current top-level definition (defun), or
;; the previous one if already at the beginning; return t if one was
;; found, nil if none.
(with-temp-buffer
(tuareg-mode)
(tuareg--lets
(insert "(* first line *)\n\n")
(let p1 (point))
(insert "type ty =\n"
" | Goo\n"
" | Baa of int\n\n")
(let p2 (point))
(insert "let a = ho hum\n"
";;\n\n")
(let p3 (point))
(insert "let g u =\n"
" while mo ma do\n"
" we wo;\n")
(let p4 (point))
(insert " ze zo\n"
" done\n")
;; Check without argument.
(goto-char p4)
(should (equal (beginning-of-defun) t))
(should (equal (point) p3))
(should (equal (beginning-of-defun) t))
(should (equal (point) p2))
(should (equal (beginning-of-defun) t))
(should (equal (point) p1))
(should (equal (beginning-of-defun) nil))
(should (equal (point) (point-min)))
;; Check with positive argument.
(goto-char p4)
(should (equal (beginning-of-defun 1) t))
(should (equal (point) p3))
(goto-char p4)
(should (equal (beginning-of-defun 2) t))
(should (equal (point) p2))
(goto-char p4)
(should (equal (beginning-of-defun 3) t))
(should (equal (point) p1))
(goto-char p4)
(should (equal (beginning-of-defun 4) nil))
(should (equal (point) (point-min)))
;; Check with negative argument.
(goto-char (point-min))
(should (equal (beginning-of-defun -1) t))
(should (equal (point) p1))
(should (equal (beginning-of-defun -1) t))
(should (equal (point) p2))
(should (equal (beginning-of-defun -1) t))
(should (equal (point) p3))
(should (equal (beginning-of-defun -1) nil))
(should (equal (point) (point-max)))
(goto-char (point-min))
(should (equal (beginning-of-defun -2) t))
(should (equal (point) p2))
(goto-char (point-min))
(should (equal (beginning-of-defun -3) t))
(should (equal (point) p3))
(goto-char (point-min))
(should (equal (beginning-of-defun -4) nil))
(should (equal (point) (point-max)))
;; We don't test with a zero argument as the behaviour for that
;; case does not seem to be very well-defined.
)))
(ert-deftest tuareg-chained-defun ()
;; Check motion by defuns that are chained by "and".
(with-temp-buffer
(tuareg-mode)
(tuareg--lets
(insert "(* *)\n\n")
(let p0 (point))
(insert "type t1 =\n"
" A\n")
(let p1 (point))
(insert "and t2 =\n"
" B\n")
(let p2a (point))
(insert "\n")
(let p2b (point))
(insert "and t3 =\n"
" C\n")
(let p3a (point))
(insert "\n")
(let p3b (point))
(insert "let f1 x =\n"
" aa\n")
(let p4 (point))
(insert "and f2 x =\n"
" bb\n")
(let p5a (point))
(insert "\n")
(let p5b (point))
(insert "and f3 x =\n"
" let ff1 y =\n"
" cc\n"
" and ff2 y = (\n")
(let p6 (point))
(insert " qq ww) + dd\n"
" and ff3 y =\n"
" for i = 1 to 10 do\n"
" ee;\n")
(let p7 (point))
(insert " ff;\n"
" done\n")
(let p8a (point))
(insert "\n")
(let p8b (point))
(insert "exception E\n")
;; Walk backwards from the end.
(goto-char (point-max))
(beginning-of-defun)
(should (equal (point) p8b))
(beginning-of-defun)
(should (equal (point) p5b))
(beginning-of-defun)
(should (equal (point) p4))
(beginning-of-defun)
(should (equal (point) p3b))
(beginning-of-defun)
(should (equal (point) p2b))
(beginning-of-defun)
(should (equal (point) p1))
(beginning-of-defun)
(should (equal (point) p0))
(beginning-of-defun)
(should (equal (point) (point-min)))
;; Walk forwards from the beginning.
(end-of-defun)
(should (equal (point) p1))
(end-of-defun)
(should (equal (point) p2a))
(end-of-defun)
(should (equal (point) p3a))
(end-of-defun)
(should (equal (point) p4))
(end-of-defun)
(should (equal (point) p5a))
(end-of-defun)
(should (equal (point) p8a))
(end-of-defun)
(should (equal (point) (point-max)))
;; Jumps from inside a defun.
(goto-char p7)
(beginning-of-defun)
(should (equal (point) p5b))
(goto-char p6)
(end-of-defun)
(should (equal (point) p8a)))))
(ert-deftest tuareg-phrase-discovery-1 ()
(with-temp-buffer
(tuareg-mode)
(tuareg--lets
(insert "let a = 1 and b = 2 in a + b\n")
(let p1 (point))
(insert "let f x =\n"
" x + 1\n")
(let p2a (point))
(insert "and g x =\n"
" x * 2\n")
(let p2b (point))
(insert "type ta = A\n"
" | B of tb\n")
(let p3a (point))
(insert "and tb = C\n"
" | D of ta\n")
(insert ";;\n")
(let p3b (point))
(goto-char (point-min))
(end-of-defun)
(should (equal (point) p1))
(end-of-defun)
(should (equal (point) p2a))
(end-of-defun)
(should (equal (point) p2b))
(end-of-defun)
(should (equal (point) p3a))
(end-of-defun)
(should (equal (point) p3b))
(beginning-of-defun)
(should (equal (point) p3a))
(beginning-of-defun)
(should (equal (point) p2b))
(beginning-of-defun)
(should (equal (point) p2a))
(beginning-of-defun)
(should (equal (point) p1))
(beginning-of-defun)
(should (equal (point) (point-min)))
(should (equal (tuareg-discover-phrase (point-min))
(list (point-min) (1- p1) (1- p1))))
(should (equal (tuareg-discover-phrase p1)
(list p1 (1- p2b) (1- p2b))))
(should (equal (tuareg-discover-phrase p2b)
(list p2b (1- p3b) (1- p3b)))))))
(ert-deftest tuareg-phrase-discovery-2 ()
(let ((lines
'("(1 < 2) = false;;"
"'a';;"
"\"abc\" ^ \" \" ^ \"def\";;"
"{|with \\ special \" chars|};;"
"max 1 2;;"
"if true then 1 else 2 ;;"
"while false do print_endline \"a\" done ;;"
"for i = 1 to 3 do print_int i done ;;"
"open Stdlib.Printf;;"
"begin print_char 'a'; print_char 'b'; end ;;"
"match [1;2] with a :: _ -> a | [] -> 3 ;;"
"exception E of int * string ;;"
"external myid : 'a -> 'a = \"%identity\";;"
"class k = object method m = 1 end;;")))
(with-temp-buffer
(tuareg-mode)
(dolist (line lines)
(insert line "\n"))
;; Check movement by defun.
(goto-char (point-min))
(let ((pos (point-min)))
(dolist (line lines)
(let ((next-pos (+ pos (length line) 1)))
(ert-info ((prin1-to-string line) :prefix "line: ")
(end-of-defun)
(should (equal (point) next-pos))
(setq pos next-pos))))
(dolist (line (reverse lines))
(let ((prev-pos (- pos (length line) 1)))
(ert-info ((prin1-to-string line) :prefix "line: ")
(beginning-of-defun)
(should (equal (point) prev-pos))
(setq pos prev-pos)))))
;; Check phrase discovery.
(let ((pos (point-min)))
(dolist (line lines)
(let ((next-pos (+ pos (length line) 1)))
(ert-info ((prin1-to-string line) :prefix "line: ")
(should (equal (tuareg-discover-phrase pos)
(list pos (1- next-pos) (1- next-pos))))
(setq pos next-pos))))))))
(ert-deftest tuareg-defun-separator ()
;; Check correct handling of ";;"-separated defuns/phrases.
(with-temp-buffer
(tuareg-mode)
(tuareg--lets
(insert "let _ = tata 3 ;;\n")
(let p1 (point))
(insert "abc def ;;\n")
(let p2 (point))
(insert "let _ = tata 3\n"
";;\n")
(let p3 (point))
(insert "ghi jkl\n"
";;\n")
(let p4 (point))
(insert "type spell =\n"
" | Frotz\n"
" | Xyzzy\n"
";;\n")
(let p5 (point))
(goto-char (point-min))
(end-of-defun)
(should (equal (point) p1))
(end-of-defun)
(should (equal (point) p2))
(end-of-defun)
(should (equal (point) p3))
(end-of-defun)
(should (equal (point) p4))
(end-of-defun)
(should (equal (point) p5))
(beginning-of-defun)
(should (equal (point) p4))
(beginning-of-defun)
(should (equal (point) p3))
(beginning-of-defun)
(should (equal (point) p2))
(beginning-of-defun)
(should (equal (point) p1))
(beginning-of-defun)
(should (equal (point) (point-min)))
(should (equal (tuareg-discover-phrase (point-min))
(list (point-min) (1- p1) (1- p1))))
(should (equal (tuareg-discover-phrase p1)
(list p1 (1- p2) (1- p2))))
(should (equal (tuareg-discover-phrase (+ p1 2))
(list p1 (1- p2) (1- p2))))
(should (equal (tuareg-discover-phrase p2)
(list p2 (1- p3) (1- p3))))
(should (equal (tuareg-discover-phrase p3)
(list p3 (1- p4) (1- p4))))
(should (equal (tuareg-discover-phrase p4)
(list p4 (1- p5) (1- p5))))
)))
(ert-deftest tuareg-class-type ()
(with-temp-buffer
(tuareg-mode)
(tuareg--lets
(insert "class type my_class_type =\n"
" object\n"
" method meth_1 : int\n"
" method meth_2 : unit\n"
" end;;\n")
(let p1 (point))
(goto-char (point-min))
(end-of-defun)
(should (equal (point) p1))
(beginning-of-defun)
(should (equal (point) (point-min)))
(should (equal (tuareg-discover-phrase (point-min))
(list (point-min) (1- p1) (1- p1)))))))
(defconst tuareg-test--compilation-messages
'((("File \"file.ml\", line 4, characters 6-7:\n"
"Error: This expression has type int\n"
"This is not a function; it cannot be applied.\n")
((1 error "file.ml" 4 4 6 6)))
(("File \"file.ml\", line 3, characters 6-7:\n"
"Warning 26: unused variable y.\n")
((1 warning "file.ml" 3 3 6 6)))
(("File \"helloworld.ml\", line 2, characters 36-64:\n"
"2 | module rec A: sig type t += A end = struct type t += A = B.A end\n"
" ^^^^^^^^^^^^^^^^^^^^^^^^^^^^\n"
"Error: Cannot safely evaluate the definition of the following cycle\n"
" of recursively-defined modules: A -> B -> A.\n")
((1 error "helloworld.ml" 2 2 36 63)))
(("File \"helloworld.ml\", lines 4-7, characters 6-3:\n"
"4 | ......struct\n"
"5 | module F(X:sig end) = struct end\n"
"6 | let f () = B.value\n"
"7 | end\n"
"Error: Cannot safely evaluate the definition of the following cycle\n"
" of recursively-defined modules: A -> B -> A.\n")
((1 error "helloworld.ml" 4 7 6 2)))
(("File \"robustmatch.ml\", lines 33-37, characters 6-23:\n"
" 9 | ......match t1, t2, x with\n"
"10 | | AB, AB, A -> ()\n"
"11 | | MAB, _, A -> ()\n"
"12 | | _, AB, B -> ()\n"
"13 | | _, MAB, B -> ()\n"
"Warning 8: this pattern-matching is not exhaustive.\n"
"Here is an example of a case that is not matched:\n"
"(AB, MAB, A)\n")
((1 warning "robustmatch.ml" 33 37 6 22)))
(("File \"robustmatch.ml\", lines 33-37, characters 6-23:\n"
" 9 | ......match t1, t2, x with\n"
"10 | | AB, AB, A -> ()\n"
"11 | | MAB, _, A -> ()\n"
"12 | | _, AB, B -> ()\n"
"13 | | _, MAB, B -> ()\n"
"Warning 8 [partial-match]: this pattern-matching is not exhaustive.\n"
"Here is an example of a case that is not matched:\n"
"(AB, MAB, A)\n")
((1 warning "robustmatch.ml" 33 37 6 22)))
(("File \"main.ml\", line 13, characters 34-35:\n"
"13 | let f : M.t -> M.t = fun M.C -> y\n"
" ^\n"
"Error: This expression has type M/2.t but an expression was expected of type\n"
" M/1.t\n"
" File \"main.ml\", line 10, characters 2-41:\n"
" Definition of module M/1\n"
" File \"main.ml\", line 7, characters 0-32:\n"
" Definition of module M/2\n")
((1 error "main.ml" 13 13 34 34)
(225 info "main.ml" 10 10 2 40)
(308 info "main.ml" 7 7 0 31)))
(("File \"alrt.ml\", line 25, characters 9-10:\n"
"25 | val x: t [@@ocaml.deprecated]\n"
" ^\n"
"Alert deprecated: t\n")
((1 warning "alrt.ml" 25 25 9 9)))
(("Fatal error: exception Bad.Disaster(\"oh no!\")\n"
"Raised at file \"bad.ml\", line 5, characters 4-22\n"
"Called from file \"worse.ml\" (inlined), line 9, characters 2-5\n"
"Called from file \"worst.ml\", line 12, characters 8-18\n")
((47 error "bad.ml" 5 5 4 21)
(96 error "worse.ml" 9 9 2 4)
(158 error "worst.ml" 12 12 8 17)))
(("Fatal error: exception Bad.Disaster(\"oh no!\")\n"
"Raised at Bad.f in file \"bad.ml\", line 5, characters 4-22\n"
"Called from Bad.g in file \"worse.ml\" (inlined), line 9, characters 2-5\n"
"Called from Bad in file \"worst.ml\", line 12, characters 8-18\n")
((47 error "bad.ml" 5 5 4 21)
(105 error "worse.ml" 9 9 2 4)
(176 error "worst.ml" 12 12 8 17)))
(("Fatal error: exception Hell\n"
"Raised by primitive operation at Murky.depths in file \"inferno.ml\", line 399, characters 28-54\n"
"Called from Nasty.f in file \"nasty.ml\", line 7, characters 13-40\n"
"Re-raised at Smelly.f in file \"smelly.ml\", line 14, characters 12-19\n"
"Called from Rubbish.g in file \"rubbish.ml\", line 17, characters 2-5\n")
((29 error "inferno.ml" 399 399 28 53)
(124 error "nasty.ml" 7 7 13 39)
(189 error "smelly.ml" 14 14 12 18)
(258 error "rubbish.ml" 17 17 2 4))))
"Compilation message test data.
Each element is (STRINGS ERRORS) where
STRINGS is a list of strings forming the message when concatenated
ERRORS is a list of error descriptions, each being
(POS TYPE FILE LINE-START LINE-END COLUMN-START COLUMN-END)
where
POS is the position of the error in the message (1-based)
TYPE is one of `error', `warning' or `info'
FILE is the file name of the error
LINE-START, LINE-END, COLUMN-START and COLUMN-END are the reported
line and column numbers, start and end, for that error")
(defun tuareg-test--extract-message-info (string pos)
"Parse STRING as a compilation message.
Return (FILE TYPE START-LINE END-LINE START-COL END-COL)."
(with-temp-buffer
;; This function makes some assumptions about the compilation-mode
;; internals and may need adjustment to work with future Emacs
;; versions.
(font-lock-mode -1)
(let ((compilation-locs (make-hash-table)))
(insert string)
(compilation-parse-errors (point-min) (point-max))
(let ((msg (get-text-property pos 'compilation-message)))
(and msg
(let* ((loc (compilation--message->loc msg))
(end-loc (compilation--message->end-loc msg))
(type (compilation--message->type msg))
(start-line (compilation--loc->line loc))
(start-col (compilation--loc->col loc))
(end-line (compilation--loc->line end-loc))
(end-col (compilation--loc->col end-loc))
(fs (compilation--loc->file-struct loc))
(file (caar fs)))
(list file
(pcase type
(0 'info)
(1 'warning)
(2 'error))
start-line end-line
;; Emacs internally adds 1 to the end column so
;; we compensate for that to get the actual
;; number in the message.
start-col (and end-col (1- end-col)))))))))
(defun tuareg-test--have-end-column-bug ()
"Check for the compilation message end-column bug."
(let ((compilation-error-regexp-alist
`((,(rx bol
(group (+ alnum)) ","
(group (+ digit)) ","
(group (+ digit)) ","
(group (+ digit)) ","
(+ digit) ";")
1 (2 . 3) (4 . (lambda () 17))))))
(pcase (tuareg-test--extract-message-info "abc,1,2,3,4; error\n" 1)
(`(,_ ,_ ,_ ,_ ,_ 16) t)
(`(,_ ,_ ,_ ,_ ,_ 17) nil)
(x (error "%S" x)))))
(ert-deftest tuareg-compilation-message ()
(let ((buggy-emacs-28 (and (equal emacs-major-version 28)
(tuareg-test--have-end-column-bug))))
(dolist (case tuareg-test--compilation-messages)
(let ((str (apply #'concat (nth 0 case)))
(errors (nth 1 case)))
(ert-info (str :prefix "message: ")
(pcase-dolist (`(,pos ,type ,file ,start-line ,end-line
,start-col ,end-col)
errors)
;; Temporary hack to make the tests pass until the Emacs snapshot
;; used in the CI has been updated to the version expected by
;; the code (ie, where the compilation message column bug has been
;; fixed). The bug was fixed in emacs/master
;; aa5437493b1ca539409495ecdc54cf420ea110b9.
(when buggy-emacs-28
(setq end-col (1- end-col)))
(let ((message-info (tuareg-test--extract-message-info str pos)))
(when (< emacs-major-version 27)
;; Prior to Emacs 27, a bug in compilation-mode caused the
;; message type to be wrong in some cases (Emacs bug#34479).
;; Pretend that the test passed anyway.
(setq type (nth 1 message-info)))
(should (equal message-info
(list file type
start-line end-line
start-col end-col))))))))))
(defun tuareg-test--comment-region (text)
(with-temp-buffer
(tuareg-mode)
(insert text)
(comment-region (point-min) (point-max))
(buffer-string)))
(ert-deftest tuareg-comment-region-style ()
"Check that commenting out code works as expected. See issue #216."
;; Non-indented code.
(should (let ((comment-style 'indent))
(equal (tuareg-test--comment-region
"let f x =\n g x\n y\n")
"(* let f x = *)\n(* g x *)\n(* y *)\n")))
(should (let ((comment-style 'multi-line)
(comment-continue " * "))
(equal (tuareg-test--comment-region
"let f x =\n g x\n y\n")
"(* let f x =\n * g x\n * y *)\n")))
(should (let ((comment-style 'multi-line))
;; `comment-continue' should default to " * "
(equal (tuareg-test--comment-region
"let f x =\n g x\n y\n")
"(* let f x =\n * g x\n * y *)\n")))
(should (let ((comment-style 'multi-line)
(comment-continue " "))
(equal (tuareg-test--comment-region
"let f x =\n g x\n y\n")
"(* let f x =\n g x\n y *)\n")))
;; Indented code.
(should (let ((comment-style 'indent))
(equal (tuareg-test--comment-region
" epsilon\n tau\n")
" (* epsilon *)\n (* tau *)\n")))
(should (let ((comment-style 'multi-line)
(comment-continue " * "))
(equal (tuareg-test--comment-region
" epsilon\n tau\n")
" (* epsilon\n * tau *)\n")))
(should (let ((comment-style 'multi-line)
(comment-continue " "))
(equal (tuareg-test--comment-region
" epsilon\n tau\n")
" (* epsilon\n tau *)\n"))))
(defun tuareg-test--comment-uncomment-region (text)
(equal text
(with-temp-buffer
(tuareg-mode)
(insert text)
(comment-region (point-min) (point-max))
(uncomment-region (point-min) (point-max))
(buffer-string))))
(ert-deftest tuareg-comment-uncomment-region ()
"Check that commenting out code then uncommenting it leads to
the original code."
(should (let ((comment-style 'indent))
(tuareg-test--comment-uncomment-region
"let f x =\n g x\n y\n")))
(should (let ((comment-style 'multi-line)
(comment-continue " * "))
(tuareg-test--comment-uncomment-region
"let f x =\n g x\n y\n")))
(should (let ((comment-style 'multi-line))
(tuareg-test--comment-uncomment-region
"let f x =\n g x\n y\n")))
(should (let ((comment-style 'multi-line)
(comment-continue " "))
(tuareg-test--comment-uncomment-region
"let f x =\n g x\n y\n"))))
(defun tuareg-test--do-at (text pos fun)
"Call FUN in TEXT at POS and return the resulting text."
(with-temp-buffer
(tuareg-mode)
(electric-indent-mode 1)
(insert text)
(goto-char pos)
(funcall fun)
(buffer-substring-no-properties (point-min) (point-max))))
(defun tuareg-test--line-start (text line)
"Position of start of LINE (0-based) in TEXT."
(let ((ofs 0))
(while (and (> line 0)
(let ((nl (string-match-p "\n" text ofs)))
(setq ofs (1+ nl))
(setq line (1- line)))))
(1+ ofs)))
(defun tuareg-test--do-at-line (text line fun)
"Call FUN in TEXT at start of LINE (0-based) and return the resulting text."
(tuareg-test--do-at text (tuareg-test--line-start text line) fun))
(ert-deftest tuareg-indent-comment-text ()
;; Indenting a line should use the indentation of the previous line's text.
(should (equal (tuareg-test--do-at-line
(concat " (** alpha\n"
"beta\n")
1 #'indent-for-tab-command)
(concat " (** alpha\n"
" beta\n")))
;; Tab should indent even at the end of the line.
(should (equal (tuareg-test--do-at
(concat " (** alpha\n"
"beta")
17 #'indent-for-tab-command)
(concat " (** alpha\n"
" beta")))
;; An interactive `newline' should indent the new line correctly
;; in Emacs 28 and later.
(when (>= emacs-major-version 28)
(should (equal (tuareg-test--do-at
"(** alpha"
10 (lambda () (call-interactively #'newline)))
(concat "(** alpha\n"
" "))))
;; The previous line's indentation should be respected and preserved.
(should (equal (tuareg-test--do-at-line
(concat " (* alpha\n"
" beta\n"
" gamma\n")
2 #'indent-for-tab-command)
(concat " (* alpha\n"
" beta\n"
" gamma\n")))
;; Use the previous nonempty line for indentation.
(should (equal (tuareg-test--do-at-line
(concat " (* alpha\n"
" beta\n"
" \n"
" gamma\n")
3 #'indent-for-tab-command)
(concat " (* alpha\n"
" beta\n"
" \n"
" gamma\n")))
;; Indent text after @-tags in doc comments by 2 more spaces.
(should (equal (tuareg-test--do-at-line
(concat " (** alpha\n"
" @param beta\n"
" gamma\n")
2 #'indent-for-tab-command)
(concat " (** alpha\n"
" @param beta\n"
" gamma\n")))
;; An @-tag starts a new paragraph.
(should (equal (tuareg-test--do-at-line
(concat " (** alpha\n"
" @param beta\n"
" @return gamma\n")
2 #'indent-for-tab-command)
(concat " (** alpha\n"
" @param beta\n"
" @return gamma\n")))
;; @-tags are not special in plain comments.
(should (equal (tuareg-test--do-at-line
(concat " (* alpha\n"
" @param beta\n"
" gamma\n")
2 #'indent-for-tab-command)
(concat " (* alpha\n"
" @param beta\n"
" gamma\n")))
;; Filling one paragraph does not affect other paragraphs.
(should (equal (tuareg-test--do-at-line
(concat " (* alpha beta gamma\n"
"delta epsilon\n"
"\n"
"zeta eta theta iota kappa *)\n")
1 (lambda () (let ((fill-column 17))
(funcall (local-key-binding (kbd "M-q"))))))
(concat " (* alpha beta\n"
" gamma delta\n"
" epsilon\n"
"\n"
"zeta eta theta iota kappa *)\n")))
;; Filling affects the preceding paragraph, not the succeeding.
(should (equal (tuareg-test--do-at-line
(concat " (* alpha beta gamma\n"
"delta epsilon\n"
"\n"
"zeta eta theta iota kappa *)\n")
2 (lambda () (let ((fill-column 17))
(funcall (local-key-binding (kbd "M-q"))))))
(concat " (* alpha beta\n"
" gamma delta\n"
" epsilon\n"
"\n"
"zeta eta theta iota kappa *)\n")))
;; A paragraph's indentation is determined by its first line.
(should (equal (tuareg-test--do-at-line
(concat " (* alpha\n"
" beta\n"
"\n"
" gamma\n"
"delta epsilon zeta eta *)\n")
3 (lambda () (let ((fill-column 19))
(funcall (local-key-binding (kbd "M-q"))))))
(concat " (* alpha\n"
" beta\n"
"\n"
" gamma delta\n"
" epsilon zeta\n"
" eta *)\n")))
;; @-tags separate paragraphs in doc comments.
(should (equal (tuareg-test--do-at-line
(concat " (** alpha\n"
" beta\n"
" @param gamma delta epsilon\n"
" @param zeta eta theta iota\n")
4 (lambda () (let ((fill-column 25))
(funcall (local-key-binding (kbd "M-q"))))))
(concat " (** alpha\n"
" beta\n"
" @param gamma delta epsilon\n"
" @param zeta eta\n"
" theta iota\n")))
)
(provide 'tuareg-tests)
tuareg-3.0.1/tuareg.el 0000664 0000000 0000000 00000533103 14315315656 0014631 0 ustar 00root root 0000000 0000000 ;;; tuareg.el --- OCaml mode -*- coding: utf-8; lexical-binding:t -*-
;; Copyright (C) 1997-2006 Albert Cohen, all rights reserved.
;; Copyright (C) 2011-2022 Free Software Foundation, Inc.
;; Copyright (C) 2009-2010 Jane Street Holding, LLC.
;; Author: Albert Cohen
;; Sam Steingold
;; Christophe Troestler
;; Till Varoquaux
;; Sean McLaughlin
;; Stefan Monnier
;; Maintainer: Christophe Troestler
;; Stefan Monnier
;; Created: 8 Jan 1997
;; Version: 3.0.1
;; Package-Requires: ((emacs "26.3") (caml "4.8"))
;; Keywords: ocaml languages
;; Homepage: https://github.com/ocaml/tuareg
;; EmacsWiki: TuaregMode
;; This file is *NOT* part of GNU Emacs.
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see .
;;; Commentary:
;;
;; Tuareg helps editing OCaml code, to highlight important parts of
;; the code, to run an OCaml REPL, and to run the OCaml debugger
;; within Emacs.
;; See https://github.com/ocaml/tuareg for customization tips.
;;; Installation:
;;
;; If you have permissions to the local `site-lisp' directory, you
;; only have to copy `tuareg.el', `ocamldebug.el'
;; and `tuareg-site-file.el'. Otherwise, copy the previous files
;; to a local directory and add the following line to your `.emacs':
;;
;; (add-to-list 'load-path "DIR")
;;; Usage:
;;
;; Tuareg allows you to run batch OCaml compilations from Emacs (using
;; M-x compile) and browse the errors (C-x `). Typing C-x ` sets the
;; point at the beginning of the erroneous program fragment, and the
;; mark at the end. Under Emacs, the program fragment is temporarily
;; highlighted.
;;
;; M-x tuareg-run-ocaml (or simply `run-ocaml') starts an OCaml
;; REPL (aka toplevel) with input and output in an Emacs buffer named
;; `*OCaml*. This gives you the full power of Emacs to edit
;; the input to the OCaml REPL. This mode is based on comint so
;; you get all the usual comint features, including command history. A
;; hook named `tuareg-interactive-mode-hook' may be used for
;; customization.
;;
;; Typing C-c C-e in a buffer in tuareg mode sends the current phrase
;; (containing the point) to the OCaml REPL, and evaluates it. If
;; you type one of these commands before M-x tuareg-run-ocaml, the
;; REPL will be started automatically.
;;
;; M-x ocamldebug FILE starts the OCaml debugger ocamldebug on the
;; executable FILE, with input and output in an Emacs buffer named
;; *ocamldebug-FILE*. It is similar to April 1996 version, with minor
;; changes to support XEmacs, Tuareg and OCaml. Furthermore, package
;; `thingatpt' is not required any more.
;;; Code:
(require 'cl-lib)
(require 'easymenu)
(require 'find-file)
(require 'subr-x)
(require 'seq)
(require 'caml-help nil t)
(require 'caml-types nil t)
(require 'tuareg-opam)
(require 'tuareg-compat)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Compatibility functions
(defun tuareg-editing-ls3 ()
"Tell whether we are editing Lucid Synchrone syntax."
(string-match-p "\\.ls\\'" (or buffer-file-name (buffer-name))))
(defun tuareg-editing-ocamllex ()
"Tell whether we are editing OCamlLex syntax."
(string-match-p "\\.mll\\'" (or buffer-file-name (buffer-name))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Import types and help features
(defvar tuareg-with-caml-mode-p
(and (featurep 'caml-types) (featurep 'caml-help)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; User customizable variables
(require 'smie)
;; Use the standard `customize' interface or `tuareg-mode-hook' to
;; Configure these variables
(require 'custom)
(defgroup tuareg nil
"Support for the OCaml language."
:link '(url-link "https://github.com/ocaml/tuareg")
:group 'languages)
;; Indentation defaults
(defcustom tuareg-default-indent 2
"Default indentation.
Global indentation variable (large values may lead to indentation overflows).
When no governing keyword is found, this value is used to indent the line
if it has to."
:group 'tuareg :type 'integer)
(defcustom tuareg-support-camllight nil
"If true, handle Caml Light character syntax (incompatible with labels)."
:group 'tuareg :type 'boolean
:set (lambda (var val)
(set-default var val)
(when (boundp 'tuareg-mode-syntax-table)
(modify-syntax-entry ?` (if val "\"" ".")
tuareg-mode-syntax-table))))
(defcustom tuareg-support-metaocaml nil
"If true, handle MetaOCaml syntax."
:group 'tuareg :type 'boolean
:set (lambda (var val)
(set-default var val)
(ignore-errors
(dolist (buf (buffer-list))
(with-current-buffer buf
(when (derived-mode-p 'tuareg-mode 'tuareg-interactive-mode)
(tuareg--install-font-lock)))))))
(defcustom tuareg-in-indent 0 ; tuareg-default-indent
"How many spaces to indent from a `in' keyword.
Upstream
recommends 0, and this is what we default to since 2.0.1
instead of the historical `tuareg-default-indent'."
:group 'tuareg :type 'integer)
(defcustom tuareg-with-indent 0
"How many spaces to indent from a `with' keyword.
The examples at
show the `|' is aligned with `match', thus 0 is the default value."
:group 'tuareg :type 'integer)
(defcustom tuareg-match-clause-indent 1
"How many spaces to indent a clause of match after a pattern `| ... ->'
or `... ->' (pattern without preceding `|' in the first clause of a matching).
To respect
the default is 1."
:type 'integer)
(defcustom tuareg-match-when-indent (+ 4 tuareg-match-clause-indent)
"How many spaces from `|' to indent `when' in a pattern match
| patt
when cond ->
clause"
:type 'integer)
(defcustom tuareg-match-patterns-aligned nil
"Non-nil means that the pipes for multiple patterns of a single case
are aligned instead of being slightly shifted to spot the multiple
patterns better.
function v.s. function
| A | A
| B -> ... | B -> ...
| C -> ... | C -> ... "
:group 'tuareg :type 'boolean)
;; Tuareg-Interactive
;; Configure via `tuareg-mode-hook'
;; Automatic indentation
(make-obsolete-variable 'tuareg-use-abbrev-mode
"Use `electric-indent-mode' instead." "2.2.0")
(defcustom tuareg-electric-indent nil
"Whether to automatically indent the line after typing one of
the words in `tuareg-electric-indent-keywords'. Lines starting
with `|', `)', `]`, and `}' are always indented when the
`electric-indent-mode' is turned on."
:group 'tuareg :type 'boolean)
(defcustom tuareg-electric-close-vector t
"Non-nil means electrically insert `|' before a vector-closing `]' or
`>' before an object-closing `}'.
Many people find electric keys irritating, so you can disable them by
setting this variable to nil. You should probably have this on,
though, if you also have `tuareg-electric-indent' on."
:group 'tuareg :type 'boolean)
(defcustom tuareg-highlight-all-operators nil
"If t, highlight all operators (as opposed to unusual ones).
This is not turned on by default because this makes font-lock
much less efficient."
:group 'tuareg :type 'boolean)
(defcustom tuareg-other-file-alist
'(("\\.pp\\.mli\\'" (".ml" ".mll" ".mly" ".pp.ml"))
("\\.mli\\'" (".ml" ".mll" ".mly" ".pp.ml"))
("\\.pp\\.ml\\'" (".mli"))
("\\.ml\\'" (".mli"))
("\\.mll\\'" (".mli"))
("\\.mly\\'" (".mli"))
("\\.eliomi\\'" (".eliom"))
("\\.eliom\\'" (".eliomi")))
"Associative list of alternate extensions to find.
See `ff-other-file-alist'."
:group 'tuareg
:type '(repeat (list regexp (choice (repeat string) function))))
(defcustom tuareg-comment-show-paren t
"Highlight comment delimiters in `show-paren-mode' if non-nil."
:group 'tuareg
:type 'boolean)
(defcustom tuareg-interactive-scroll-to-bottom-on-output nil
"Controls when to scroll to the bottom of the interactive buffer
upon evaluating an expression.
See `comint-scroll-to-bottom-on-output' for details."
:group 'tuareg :type 'boolean
:set (lambda (var val)
(set-default var val)
(when (boundp 'comint-scroll-to-bottom-on-output)
(dolist (buf (buffer-list))
(with-current-buffer buf
(when (derived-mode-p 'tuareg-interactive-mode)
(setq-local comint-scroll-to-bottom-on-output val)))))))
(defcustom tuareg-skip-after-eval-phrase t
"Non-nil means skip to the end of the phrase after evaluation in the
OCaml REPL."
:group 'tuareg :type 'boolean)
(defcustom tuareg-interactive-read-only-input nil
"Non-nil means input sent to the OCaml REPL is read-only."
:group 'tuareg :type 'boolean)
(defcustom tuareg-interactive-echo-phrase t
"Non-nil means echo phrases in the REPL buffer when sending
them to the OCaml REPL."
:group 'tuareg :type 'boolean)
(defcustom tuareg-interactive-input-font-lock t
"Non nil means Font-Lock for REPL input phrases."
:group 'tuareg :type 'boolean)
(defcustom tuareg-interactive-output-font-lock t
"Non nil means Font-Lock for REPL output messages."
:group 'tuareg :type 'boolean)
(defcustom tuareg-interactive-error-font-lock t
"Non nil means Font-Lock for REPL error messages."
:group 'tuareg :type 'boolean)
(defcustom tuareg-display-buffer-on-eval t
"Non nil means pop up the OCaml REPL when evaluating code."
:group 'tuareg :type 'boolean)
(defcustom tuareg-manual-url
"https://v2.ocaml.org/manual/"
"URL to the OCaml reference manual."
:group 'tuareg :type 'string)
(defcustom tuareg-browser #'browse-url
"Name of function that displays the OCaml reference manual.
Valid names are `browse-url', `browse-url-firefox', etc."
:group 'tuareg :type 'function)
(defcustom tuareg-library-path "/usr/local/lib/ocaml/"
"Name of directory holding the OCaml library."
:group 'tuareg :type 'string)
(defcustom tuareg-mode-line-other-file nil
"If non-nil, display the (extension of the) alternative file in mode line."
:type 'boolean)
(defvar tuareg-options-list
`(["Prettify symbols" prettify-symbols-mode
:style toggle :selected prettify-symbols-mode :active t])
"List of menu-configurable Tuareg options.")
(defvar tuareg-interactive-options-list
'(("Skip phrase after evaluation" . 'tuareg-skip-after-eval-phrase)
("Echo phrase in interactive buffer" . 'tuareg-interactive-echo-phrase)
"---"
("Font-lock interactive input" . 'tuareg-interactive-input-font-lock)
("Font-lock interactive output" . 'tuareg-interactive-output-font-lock)
("Font-lock interactive error" . 'tuareg-interactive-error-font-lock)
"---"
("Read only input" . 'tuareg-interactive-read-only-input))
"List of menu-configurable Tuareg options.")
(defvar tuareg-interactive-program "ocaml -nopromptcont"
"Default program name for invoking an OCaml REPL (aka toplevel) from Emacs.")
;; Could be interesting to have this variable buffer-local
;; (e.g., ocaml vs. metaocaml buffers)
;; (make-variable-buffer-local 'tuareg-interactive-program)
(defgroup tuareg-faces nil
"Special faces for the Tuareg mode."
:group 'tuareg)
(defface tuareg-font-lock-governing-face
'((((class color) (type tty)) (:bold t))
(((background light)) (:foreground "black" :bold t))
(t (:foreground "wheat" :bold t)))
"Face description for governing/leading keywords."
:group 'tuareg-faces)
(defvar tuareg-font-lock-governing-face
'tuareg-font-lock-governing-face)
(defface tuareg-font-lock-multistage-face
'((((background light))
(:foreground "darkblue" :background "lightgray" :bold t))
(t (:foreground "steelblue" :background "darkgray" :bold t)))
"Face description for MetaOCaml staging operators."
:group 'tuareg-faces)
(defvar tuareg-font-lock-multistage-face
'tuareg-font-lock-multistage-face)
(defface tuareg-font-lock-line-number-face
'((((background light)) (:foreground "dark gray"))
(t (:foreground "gray60")))
"Face description for line numbering directives."
:group 'tuareg-faces)
(defvar tuareg-font-lock-line-number-face
'tuareg-font-lock-line-number-face)
(defface tuareg-font-lock-operator-face
'((((background light)) (:foreground "brown"))
(t (:foreground "khaki")))
"Face description for all operators."
:group 'tuareg-faces)
(defvar tuareg-font-lock-operator-face
'tuareg-font-lock-operator-face)
(defface tuareg-font-lock-module-face
'((t (:inherit font-lock-type-face))); backward compatibility
"Face description for modules and module paths."
:group 'tuareg-faces)
(defvar tuareg-font-lock-module-face
'tuareg-font-lock-module-face)
(defface tuareg-font-lock-constructor-face
'((t (:inherit default))) ;FIXME: Why not just nil?
"Face description for constructors of (polymorphic) variants and exceptions."
:group 'tuareg-faces)
(defvar tuareg-font-lock-constructor-face
'tuareg-font-lock-constructor-face)
(defface tuareg-font-lock-label-face
'((t (:inherit font-lock-constant-face keep)))
"Face description for labels."
:group 'tuareg-faces)
(defvar tuareg-font-lock-label-face
'tuareg-font-lock-label-face)
(defface tuareg-font-double-semicolon-face
'((t (:foreground "OrangeRed")))
"Face description for ;; which is not needed in standard code."
:group 'tuareg-faces)
(defvar tuareg-font-double-semicolon-face
'tuareg-font-double-semicolon-face)
(defface tuareg-font-lock-error-face
'((t (:foreground "yellow" :background "red" :bold t)))
"Face description for all errors reported to the source."
:group 'tuareg-faces)
(defvar tuareg-font-lock-error-face
'tuareg-font-lock-error-face)
(defface tuareg-font-lock-interactive-output-face
'((((background light))
(:foreground "blue4"))
(t (:foreground "grey")))
"Face description for all outputs in the REPL."
:group 'tuareg-faces)
(defvar tuareg-font-lock-interactive-output-face
'tuareg-font-lock-interactive-output-face)
(defface tuareg-font-lock-interactive-error-face
'((t :inherit font-lock-warning-face))
"Face description for all REPL errors."
:group 'tuareg-faces)
(defvar tuareg-font-lock-interactive-error-face
'tuareg-font-lock-interactive-error-face)
(defface tuareg-font-lock-interactive-directive-face
'((((background light)) (:foreground "slate gray"))
(t (:foreground "light slate gray")))
"Face description for all REPL directives such as #load."
:group 'tuareg-faces)
(defvar tuareg-font-lock-interactive-directive-face
'tuareg-font-lock-interactive-directive-face)
(defface tuareg-font-lock-attribute-face
'((t :inherit font-lock-preprocessor-face))
"Face description for OCaml attribute annotations."
:group 'tuareg-faces)
(defvar tuareg-font-lock-attribute-face
'tuareg-font-lock-attribute-face)
(defface tuareg-font-lock-infix-extension-node-face
'((t :inherit font-lock-preprocessor-face))
"Face description for OCaml the infix extension node."
:group 'tuareg-faces)
(defvar tuareg-font-lock-infix-extension-node-face
'tuareg-font-lock-infix-extension-node-face)
(defface tuareg-font-lock-extension-node-face
'((default :inherit tuareg-font-lock-infix-extension-node-face)
(((background dark)) :foreground "LightSteelBlue")
(t :background "gray92"))
"Face description for OCaml extension nodes."
:group 'tuareg-faces)
(defvar tuareg-font-lock-extension-node-face
'tuareg-font-lock-extension-node-face)
(defface tuareg-font-lock-doc-markup-face
`((t :inherit ,(if (facep 'font-lock-doc-markup-face)
'font-lock-doc-markup-face ; Emacs ≥28.
'font-lock-constant-face)))
"Face for mark-up syntax in OCaml doc comments."
:group 'tuareg-faces)
(defface tuareg-font-lock-doc-verbatim-face
'((t :inherit fixed-pitch)) ; FIXME: find something better
"Face for verbatim text in OCaml doc comments (inside {v ... v})."
:group 'tuareg-faces)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Support definitions
;; This function is different from the standard in that it does NOT signal
;; errors at beginning-of-buffer.
(defun tuareg-backward-char (&optional step)
(if step (goto-char (- (point) step))
(goto-char (1- (point)))))
(defun tuareg-in-indentation-p ()
"Return non-nil if all chars between beginning of line and point are blanks."
(save-excursion
(skip-chars-backward " \t")
(bolp)))
(defun tuareg-in-literal-or-comment-p (&optional pos)
"Return non-nil if point is inside an OCaml literal or comment."
(nth 8 (syntax-ppss pos)))
(defun tuareg--point-after-comment-p ()
"Return non-nil if a comment precedes the point."
(and (eq (char-before) ?\))
(eq (char-before (1- (point))) ?*) ; implies position is in range
(save-excursion
(nth 4 (syntax-ppss (1- (point)))))))
(defun tuareg-backward-up-list ()
;; FIXME: not clear if moving out of a string/comment should count as 1 or no.
(condition-case nil
(backward-up-list)
(scan-error (goto-char (point-min)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Font-lock in Emacs
;; Originally by Stefan Monnier
(defcustom tuareg-font-lock-symbols nil
"Display fun and -> and such using symbols in fonts.
This may sound like a neat trick, but note that it can change the
alignment and can thus lead to surprises. On recent Emacs >= 24.4,
use `prettify-symbols-mode'."
:group 'tuareg :type 'boolean)
(make-obsolete-variable 'tuareg-font-lock-symbols
'prettify-symbols-mode "Emacs-24.4")
(defcustom tuareg-prettify-symbols-full nil
"If non-nil, add fun and -> and such to be prettified with symbols.
This may sound like a neat trick, but note that it can change the
alignment and can thus lead to surprises. By default, only symbols that
do not perturb in essential ways the alignment are used. See
`tuareg-prettify-symbols-basic-alist' and
`tuareg-prettify-symbols-extra-alist'."
:group 'tuareg :type 'boolean)
(defvar tuareg-prettify-symbols-basic-alist
`(("sqrt" . ?√)
("cbrt" . ?∛)
("&&" . ?∧) ; 'LOGICAL AND' (U+2227)
("||" . ?∨) ; 'LOGICAL OR' (U+2228)
("+." . ?∔) ;DOT PLUS (U+2214)
("-." . ?∸) ;DOT MINUS (U+2238)
;;("*." . ?×)
("*." . ?∙) ; BULLET OPERATOR
("/." . ?÷)
("+:" . "̈+"); (⨥ ＋ ➕ ⨁ ⨢)
("-:" . "̈－"); COMBINING DIAERESIS ̈- (⨪ － ➖)
("*:" . "̈∙"); (⨱ ＊ ✕ ✖ ⁑ ◦ ⨰ ⦿ ⨀ ⨂)
("/:" . "̈÷"); (➗)
("+^" . ?⨣)
("-^" . "̂－") ; COMBINING CIRCUMFLEX ACCENT
("*^" . "̂∙")
("/^" . "̂÷")
("+~" . ?⨤)
("-~" . "̃－") ; COMBINING TILDE
("*~" . "̃∙")
("/~" . "̃÷")
("<-" . ?←)
("<=" . ?≤)
(">=" . ?≥)
("<>" . ?≠)
("==" . ?≡)
("!=" . ?≢)
("<=>" . ?⇔)
("infinity" . ?∞)
;; Some greek letters for type parameters.
("'a" . ?α)
("'b" . ?β)
("'c" . ?γ)
("'d" . ?δ)
("'e" . ?ε)
("'f" . ?φ)
("'i" . ?ι)
("'k" . ?κ)
("'m" . ?μ)
("'n" . ?ν)
("'o" . ?ω)
("'p" . ?π)
("'r" . ?ρ)
("'s" . ?σ)
("'t" . ?τ)
("'x" . ?ξ)))
(defvar tuareg-prettify-symbols-extra-alist
`(("fun" . ?λ)
("not" . ?¬)
;;("or" . ?∨); should not be used as ||
("[|" . ?〚) ;; 〚
("|]" . ?〛) ;; 〛
("->" . ?→)
(":=" . ?⇐)
("::" . ?∷)))
(defun tuareg--prettify-symbols-compose-p (start end match)
"Return true iff the symbol MATCH should be composed.
See `prettify-symbols-compose-predicate'."
;; Refine `prettify-symbols-default-compose-p' so as not to compose
;; symbols for errors,...
(and (fboundp 'prettify-symbols-default-compose-p)
(prettify-symbols-default-compose-p start end match)
(not (memq (get-text-property start 'face)
'(tuareg-font-lock-error-face
tuareg-font-lock-interactive-output-face
tuareg-font-lock-interactive-error-face)))))
(defun tuareg-font-lock-compose-symbol (alist)
"Compose a sequence of ascii chars into a symbol.
Regexp match data 0 points to the chars."
;; Check that the chars should really be composed into a symbol.
(let* ((mbegin (match-beginning 0))
(mend (match-end 0))
(syntax (char-syntax (char-after mbegin))))
(if (or (eq (char-syntax (or (char-before mbegin) ?\ )) syntax)
(eq (char-syntax (or (char-after mend) ?\ )) syntax)
(memq (get-text-property mbegin 'face)
'(font-lock-doc-face
font-lock-string-face
font-lock-comment-face
tuareg-font-lock-error-face
tuareg-font-lock-interactive-output-face
tuareg-font-lock-interactive-error-face)))
;; No composition for you. Let's actually remove any composition
;; we may have added earlier and which is now incorrect.
(remove-text-properties mbegin mend '(composition))
;; That's a symbol alright, so add the composition.
(compose-region mbegin mend (cdr (assoc (match-string 0) alist)))))
;; Return nil because we're not adding any face property.
nil)
(defun tuareg-font-lock-symbols-keywords ()
(let ((alist (if tuareg-prettify-symbols-full
(append tuareg-prettify-symbols-basic-alist
tuareg-prettify-symbols-extra-alist)
tuareg-prettify-symbols-basic-alist)))
(dolist (x alist)
(when (and (or (and (number-or-marker-p (cdr x))
(char-displayable-p (cdr x)))
(seq-every-p #'char-displayable-p (cdr x)))
(not (assoc (car x) alist))) ; not yet in alist.
(push x alist)))
(when alist
`((,(regexp-opt (mapcar #'car alist) t)
(0 (tuareg-font-lock-compose-symbol ',alist)))))))
(defvar tuareg-mode-syntax-table
(let ((st (make-syntax-table)))
(modify-syntax-entry ?_ "_" st)
(modify-syntax-entry ?. "'" st) ;Make qualified names a single symbol.
(modify-syntax-entry ?# "." st)
(modify-syntax-entry ?? ". p" st)
(modify-syntax-entry ?~ ". p" st)
;; See https://v2.ocaml.org/manual/lex.html.
(dolist (c '(?! ?$ ?% ?& ?+ ?- ?/ ?: ?< ?= ?> ?@ ?^ ?|))
(modify-syntax-entry c "." st))
(modify-syntax-entry ?' "_" st) ; ' is part of symbols (for primes).
(modify-syntax-entry
;; ` is punctuation or character delimiter (Caml Light compatibility).
?` (if tuareg-support-camllight "\"" ".") st)
(modify-syntax-entry ?\" "\"" st) ; " is a string delimiter
(modify-syntax-entry ?\\ "\\" st)
(modify-syntax-entry ?* ". 23" st)
(modify-syntax-entry ?\( "()1n" st)
(modify-syntax-entry ?\) ")(4n" st)
st)
"Syntax table in use in Tuareg mode buffers.")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Font-Lock
(defconst tuareg-font-lock-syntactic-keywords
;; Char constants start with ' but ' can also appear in identifiers.
;; Beware not to match things like '*)hel' or '"hel' since the first '
;; might be inside a string or comment.
;; Note: for compatibility with Emacs<23, we use "\\<" rather than "\\_<",
;; which depends on tuareg-font-lock-syntax turning all "_" into "w".
'(("\\<\\('\\)\\([^'\\\n]\\|\\\\.[^\\'\n \")]*\\)\\('\\)"
(1 '(7)) (3 '(7)))))
(defun tuareg-syntax-propertize (start end)
(goto-char start)
(tuareg--syntax-quotation end)
(funcall
(syntax-propertize-rules
;; When we see a '"', knowing whether it's a literal char (as opposed to
;; the end of a string followed by the beginning of a literal char)
;; requires checking syntax-ppss as in:
;; ("\\_<\\('\"'\\)"
;; (1 (unless (nth 3 (save-excursion (syntax-ppss (match-beginning 0))))
;; (string-to-syntax "\""))))
;; Not sure if it's worth the trouble since adding a space between the
;; string and the literal char is easy enough and is the usual
;; style anyway.
;; For all other cases we don't need to check syntax-ppss because, if the
;; first quote is within a string (or comment), the whole match is within
;; the string (or comment), so the syntax-properties don't hurt.
;;
;; Note: we can't just use "\\<" here because syntax-propertize is also
;; used outside of font-lock.
("\\_<\\('\\)\\(?:[^'\\\n]\\|\\\\.[^\\'\n \")]*\\)\\('\\)"
(1 "\"") (2 "\""))
("\\({\\)[a-z_]*|"
(1 (prog1 "|" (tuareg--syntax-quotation end))))
)
(point) end))
(defun tuareg--syntax-quotation (end)
(let ((ppss (syntax-ppss)))
(when (eq t (nth 3 ppss))
(pcase (char-after (nth 8 ppss))
(`?<
;; We're indeed inside a quotation.
(when (re-search-forward ">>" end 'move)
(put-text-property (1- (point)) (point)
'syntax-table (string-to-syntax "|"))))
(`?\{
;; We're inside a quoted string
;; https://v2.ocaml.org/manual/extn.html#sec244
(let ((id (save-excursion
(goto-char (1+ (nth 8 ppss)))
(buffer-substring (point)
(progn (skip-chars-forward "a-z_")
(point))))))
(when (search-forward (concat "|" id "}") end 'move)
(put-text-property (1- (point)) (point)
'syntax-table (string-to-syntax "|")))))
(c (error "Unexpected char '%c' starting delimited string" c))))))
(defmacro tuareg--syntax-rules (&rest rules)
"Generate a function to parse according to RULES.
Each argument has the form (RE BODY...) where RE is a regexp to
match and BODY what to execute upon match. BODY is executed with
point at the end of the match, `start' bound to the start of the
match and `group' to the number of the first group in RE, if any.
The returned function takes the two arguments BEGIN and END
delimiting the region of interest. "
(let ((group-number 1)
(clauses nil)
(regexps nil))
(dolist (rule rules)
(let* ((re (macroexpand (car rule)))
(body (cdr rule))
(re-ngroups (regexp-opt-depth re))
(clause-body
(if (> re-ngroups 0)
`((let ((group ,(1+ group-number)))
,@body))
body)))
(push re regexps)
(push `((match-beginning ,group-number) . ,clause-body)
clauses)
(setq group-number (+ group-number 1 re-ngroups))))
(let ((combined-re (mapconcat (lambda (re) (concat "\\(" re "\\)"))
(nreverse regexps) "\\|"))
(begin (make-symbol "begin"))
(end (make-symbol "end")))
`(lambda (,begin ,end)
(goto-char ,begin)
(while (and (< (point) ,end)
(re-search-forward ,combined-re ,end t)
(let ((start (match-beginning 0)))
(cond . ,(nreverse clauses))
t)))))))
;; FIXME: using nil here is a tad unstable -- sometimes we get a full
;; fontification as code (which is nice!), sometimes not.
(defconst tuareg-font-lock-doc-code-face nil
"Face to use for parts of a doc comment marked up as code (ie, [TEXT]).")
(defun tuareg-fontify-doc-comment (state)
(let ((beg (nth 8 state))
(end (save-excursion
(parse-partial-sexp (point) (point-max) nil nil state
'syntax-table)
(point))))
(put-text-property beg end 'face 'font-lock-doc-face)
(when (and (eq (char-after (- end 2)) ?*)
(eq (char-after (- end 1)) ?\)))
(setq end (- end 2))) ; stop before closing "*)"
(save-excursion
(let ((case-fold-search nil))
(funcall
(tuareg--syntax-rules
((rx (or "[" "{["))
;; Fontify opening bracket.
(put-text-property start (point) 'face
'tuareg-font-lock-doc-markup-face)
;; Skip balanced set of brackets.
(let ((start-end (point))
(level 1))
(while (and (< (point) end)
(re-search-forward (rx (? "\\") (in "[]"))
end 'noerror)
(let ((next (char-after (match-beginning 0))))
(cond
((eq next ?\[)
(setq level (1+ level))
t)
((eq next ?\])
(setq level (1- level))
(if (> level 0)
t
(forward-char -1)
nil))
(t t)))))
(put-text-property start-end (point) 'face
tuareg-font-lock-doc-code-face)
(if (> level 0)
;; Highlight unbalanced opening bracket.
(put-text-property start start-end 'face
'tuareg-font-lock-error-face)
;; Fontify closing bracket.
(put-text-property (point) (1+ (point)) 'face
'tuareg-font-lock-doc-markup-face)
(forward-char 1))))
((rx "]")
(put-text-property start (1+ start) 'face
'tuareg-font-lock-error-face))
;; @-tag.
((rx "@" (group (or "author" "deprecated" "param" "raise" "return"
"see" "since" "before" "version"))
word-end)
(put-text-property start (point) 'face
'tuareg-font-lock-doc-markup-face)
;; Use code face for the first argument of some tags.
(when (and (member (match-string group)
'("param" "raise" "before"))
(looking-at (rx (+ space)
(group
(+ (in "a-zA-Z0-9" "_.'-"))))))
(put-text-property (match-beginning 1) (match-end 1) 'face
tuareg-font-lock-doc-code-face)
(goto-char (match-end 0))))
;; Cross-reference.
((rx (or "{!" "{{!")
(? (or "tag" "module" "modtype" "class" "classtype" "val" "type"
"exception" "attribute" "method" "section" "const"
"recfield")
":")
(group (* (in "a-zA-Z0-9" "_.'"))))
(put-text-property start (match-beginning group) 'face
'tuareg-font-lock-doc-markup-face)
;; Use code face for the reference.
(put-text-property (match-beginning group) (match-end group) 'face
tuareg-font-lock-doc-code-face))
;; {v ... v}
((rx "{v" (in " \t\n"))
(put-text-property start (+ 3 start) 'face
'tuareg-font-lock-doc-markup-face)
(let ((verbatim-end end))
(when (re-search-forward (rx (in " \t\n") "v}")
end 'noerror)
(setq verbatim-end (match-beginning 0))
(put-text-property verbatim-end (point) 'face
'tuareg-font-lock-doc-markup-face))
(put-text-property (+ 3 start) verbatim-end 'face
'tuareg-font-lock-doc-verbatim-face)))
;; Other {..} and <..> constructs.
((rx (or (seq "{"
(or (or "-" ":" "_" "^"
"b" "i" "e" "C" "L" "R"
"ul" "ol" "%"
"{:")
;; Section header with optional label.
(seq (+ digit)
(? ":"
(+ (in "a-zA-Z0-9" "_"))))))
"}"
;; HTML-style tags
(seq "<" (? "/")
(or "b" "i" "code" "ul" "ol" "li"
"center" "left" "right"
(seq "h" (+ digit)))
">")))
(put-text-property start (point) 'face
'tuareg-font-lock-doc-markup-face))
;; Escaped syntax characters.
((rx "\\" (in "{}[]@"))))
beg end))))
nil)
(defun tuareg-font-lock-syntactic-face-function (state)
"`font-lock-syntactic-face-function' for Tuareg."
(if (nth 3 state)
font-lock-string-face
(let ((start (nth 8 state)))
(if (and (> (point-max) (+ start 2))
(eq (char-after (+ start 2)) ?*)
(not (eq (char-after (+ start 3)) ?*)))
;; This is a documentation comment
(tuareg-fontify-doc-comment state)
font-lock-comment-face))))
;; Initially empty, set in `tuareg--install-font-lock-1'
(defvar tuareg-font-lock-keywords ()
"Font-Lock patterns for Tuareg mode (basic level).")
(defvar tuareg-font-lock-keywords-1 ()
"Font-Lock patterns for Tuareg mode (intermediate level).")
(defvar tuareg-font-lock-keywords-2 ()
"Font-Lock patterns for Tuareg mode (maximum level).")
(defconst tuareg-font-lock-syntax
;; Note: as a general rule, changing syntax-table during font-lock
;; is a potential problem for syntax-ppss.
`((?_ . "w") (?' . "w"))
"Syntax changes for Font-Lock.")
(defconst tuareg--whitespace-re
;; QUESTION: Why not just "[ \t\n]*"?
;; It used to be " *[\t\n]? *" but this is inefficient since it can match
;; N spaces in N+1 different ways :-(
" *\\(?:[\t\n] *\\)?")
(defconst tuareg--id-re "\\_<[A-Za-z_][A-Za-z0-9_']*\\_>"
"Regular expression for identifiers.")
(defconst tuareg--lid-re "\\_<[a-z_][A-Za-z0-9_']*\\_>"
"Regular expression for variable names.")
(defconst tuareg--uid-re "\\_<[A-Z][A-Za-z0-9_']*\\_>"
"Regular expression for module and constructor names.")
(defun tuareg--install-font-lock (&optional interactive-p)
"Setup `font-lock-defaults'. INTERACTIVE-P says whether it is
for the interactive mode."
(let* ((id tuareg--id-re)
(lid tuareg--lid-re)
(uid tuareg--uid-re)
(attr-id1 "\\<[A-Za-z_][A-Za-z0-9_']*\\>")
(attr-id (concat attr-id1 "\\(?:\\." attr-id1 "\\)*"))
(maybe-infix-extension (concat "\\(?:%" attr-id "\\)?")); at most 1
;; Matches braces balanced on max 3 levels.
(balanced-braces
(let ((b "\\(?:[^()]\\|(")
(e ")\\)*"))
(concat b b b "[^()]*" e e e)))
(balanced-braces-no-string
(let ((b "\\(?:[^()\"]\\|(")
(e ")\\)*"))
(concat b b b "[^()\"]*" e e e)))
(balanced-braces-no-end-operator ; non-empty
(let* ((b "\\(?:[^()]\\|(")
(e ")\\)*")
(braces (concat b b "[^()]*" e e))
(end-op (concat "\\(?:[^()!$%&*+-./:<=>?@^|~]\\|("
braces ")\\)")))
(concat "\\(?:[^()!$%&*+-./:<=>?@^|~]"
;; Operator not starting with ~
"\\|[!$%&*+-./:<=>?@^|][!$%&*+-./:<=>?@^|~]*" end-op
;; Operator or label starting with ~
"\\|~\\(?:[!$%&*+-./:<=>?@^|~]+" end-op
"\\|[a-z][a-zA-Z0-9]*[: ]\\)"
"\\|(" braces e)))
(balanced-brackets
(let ((b "\\(?:[^][]\\|\\[")
(e "\\]\\)*"))
(concat b b b "[^][]*" e e e)))
(maybe-infix-attribute
(concat "\\(?:\\[@" attr-id balanced-brackets "\\]\\)*"))
(maybe-infix-ext+attr
(concat maybe-infix-extension maybe-infix-attribute))
;; FIXME: module paths with functor applications
(module-path (concat uid "\\(?:\\." uid "\\)*"))
(typeconstr (concat "\\(?:" module-path "\\.\\)?" lid))
(extended-module-name
(concat uid "\\(?: *([ A-Z]" balanced-braces ")\\)*"))
(extended-module-path
(concat extended-module-name
"\\(?: *\\. *" extended-module-name "\\)*"))
(modtype-path (concat "\\(?:" extended-module-path "\\.\\)*" id))
(typevar "'[A-Za-z_][A-Za-z0-9_']*\\>")
(typeparam (concat "\\(?:[+-]?" typevar "\\|_\\)"))
(typeparams (concat "\\(?:" typeparam "\\|( *"
typeparam " *\\(?:, *" typeparam " *\\)*)\\)"))
(typedef (concat "\\(?:" typeparams " *\\)?" lid))
;; Define 2 groups: possible path, variables
(let-ls3 (regexp-opt '("clock" "node" "static"
"present" "automaton" "where" "match"
"with" "do" "done" "unless" "until"
"reset" "every")))
(before-operator-char "[^-!$%&*+./:<=>?@^|~#?]")
(operator-char "[-!$%&*+./:<=>?@^|~]")
(operator-char-no> "[-!$%&*+./:<=?@^|~]"); for "->"
(binding-operator-char
(concat "\\(?:[-$&*+/<=>@^|]" operator-char "*\\)"))
(let-binding-g4 ; 4 groups
(concat "\\_<\\(?:\\(let\\_>" binding-operator-char "?\\)"
"\\(" maybe-infix-ext+attr
"\\)\\(?: +\\(" (if (tuareg-editing-ls3) let-ls3 "rec\\_>")
"\\)\\)?\\|\\(and\\_>" binding-operator-char "?\\)\\)"))
;; group for possible class param
(gclass-gparams
(concat "\\(\\_\\)"
" *\\(\\[ *" typevar " *\\(?:, *" typevar " *\\)*\\] *\\)?"))
;; font-lock rules common to all levels
(common-keywords
`(("^#[0-9]+ *\\(?:\"[^\"]+\"\\)?"
0 tuareg-font-lock-line-number-face t)
;; cppo
(,(concat "^ *#"
(regexp-opt '("define" "undef" "if" "ifdef" "ifndef"
"else" "elif" "endif" "include"
"warning" "error" "ext" "endext")
'symbols))
. font-lock-preprocessor-face)
;; Directives
,@(if interactive-p
`((,(concat "^# +\\(#" lid "\\)")
1 tuareg-font-lock-interactive-directive-face)
(,(concat "^ *\\(#" lid "\\)")
1 tuareg-font-lock-interactive-directive-face))
`((,(concat "^\\(#" lid "\\)")
. tuareg-font-lock-interactive-directive-face)))
(,(concat (if interactive-p "^ *#\\(?: +#\\)?" "^#")
"show\\(?:_module\\)? +\\(" uid "\\)")
1 tuareg-font-lock-module-face)
(";;+" 0 tuareg-font-double-semicolon-face)
;; Attributes (`keep' to highlight except strings & chars)
(,(concat "\\[@\\(?:@@?\\)?" attr-id balanced-brackets "\\]")
0 tuareg-font-lock-attribute-face keep)
;; Extension nodes.
(,(concat "\\(\\[%%?" attr-id "\\)" balanced-brackets "\\(\\]\\)")
(1 tuareg-font-lock-extension-node-face)
(2 tuareg-font-lock-extension-node-face))
(,(concat "[^;];\\(" maybe-infix-extension "\\)")
1 tuareg-font-lock-infix-extension-node-face)
(,(concat "\\_<\\(function\\)\\_>\\(" maybe-infix-ext+attr "\\)"
tuareg--whitespace-re "\\(" lid "\\)?")
(1 font-lock-keyword-face)
(2 tuareg-font-lock-infix-extension-node-face keep)
(3 font-lock-variable-name-face nil t))
(,(concat "\\_<\\(fun\\|match\\)\\_>\\(" maybe-infix-ext+attr "\\)")
(1 font-lock-keyword-face)
(2 tuareg-font-lock-infix-extension-node-face keep))
;; "type" to introduce a local abstract type considered a keyword
(,(concat "( *\\(type\\) +\\(" lid " *\\)+)")
(1 font-lock-keyword-face)
(2 font-lock-type-face))
(":[\n]? *\\(\\\\)"
(1 font-lock-keyword-face))
;; (lid: t), before function definitions
(,(concat "(" lid " *:\\(['_A-Za-z]"
balanced-braces-no-string "\\))")
1 font-lock-type-face keep)
;; "module type of" module-expr (here "of" is a governing
;; keyword). Must be before the modules highlighting.
(,(concat "\\<\\(module +type +of\\)\\>\\(?: +\\("
module-path "\\)\\)?")
(1 tuareg-font-lock-governing-face keep)
(2 tuareg-font-lock-module-face keep t))
;; First class modules. In these contexts, "val" and "module"
;; are not considered as "governing" (main structure of the code).
(,(concat "( *\\(module\\) +\\(" module-path "\\) *\\(?:: *\\("
balanced-braces-no-string "\\)\\)?)")
(1 font-lock-keyword-face)
(2 tuareg-font-lock-module-face)
(3 tuareg-font-lock-module-face keep t))
(,(concat "( *\\(val\\) +\\("
balanced-braces-no-end-operator "\\): +\\("
balanced-braces-no-string "\\))")
(1 font-lock-keyword-face)
(2 tuareg-font-lock-module-face)
(3 tuareg-font-lock-module-face))
(,(concat "\\_<\\(module\\)\\(" maybe-infix-ext+attr "\\)"
"\\(\\(?: +type\\)?\\(?: +rec\\)?\\)\\>\\(?: *\\("
uid "\\)\\)?")
(1 tuareg-font-lock-governing-face)
(2 tuareg-font-lock-infix-extension-node-face)
(3 tuareg-font-lock-governing-face)
(4 tuareg-font-lock-module-face keep t))
("\\_" . tuareg-font-lock-governing-face)
(,(concat (regexp-opt '("sig" "struct" "functor" "inherit"
"initializer" "object" "begin")
'symbols)
"\\(" maybe-infix-ext+attr "\\)")
(1 tuareg-font-lock-governing-face)
(2 tuareg-font-lock-infix-extension-node-face keep))
(,(regexp-opt '("constraint" "in" "end") 'symbols)
. tuareg-font-lock-governing-face)
,@(if (tuareg-editing-ls3)
`((,(concat "\\<\\(let[ \t]+" let-ls3 "\\)\\>")
. tuareg-font-lock-governing-face)))
;; "with type": "with" treated as a governing keyword
(,(concat "\\<\\(\\(?:with\\|and\\) +type\\(?: +nonrec\\)?\\_>\\) *"
"\\(" typeconstr "\\)?")
(1 tuareg-font-lock-governing-face keep)
(2 font-lock-type-face keep t))
(,(concat "\\<\\(\\(?:with\\|and\\) +module\\>\\) *\\(?:\\("
module-path "\\) *\\)?\\(?:= *\\("
extended-module-path "\\)\\)?")
(1 tuareg-font-lock-governing-face keep)
(2 tuareg-font-lock-module-face keep t)
(3 tuareg-font-lock-module-face keep t))
;; "!", "mutable", "virtual" treated as governing keywords
(,(concat "\\<\\(\\(?:val\\(" maybe-infix-ext+attr "\\)"
(if (tuareg-editing-ls3) "\\|reset\\|do")
"\\)!? +\\(?:mutable\\(?: +virtual\\)?\\_>"
"\\|virtual\\(?: +mutable\\)?\\_>\\)"
"\\|val!\\(" maybe-infix-ext+attr "\\)\\)"
"\\(?: *\\(" lid "\\)\\)?")
(2 tuareg-font-lock-infix-extension-node-face keep t)
(3 tuareg-font-lock-infix-extension-node-face keep t)
(1 tuareg-font-lock-governing-face keep t)
(4 font-lock-variable-name-face nil t))
;; "val" without "!", "mutable" or "virtual"
(,(concat "\\_<\\(val\\)\\_>\\(" maybe-infix-ext+attr "\\)"
"\\(?: +\\(" lid "\\)\\)?")
(1 tuareg-font-lock-governing-face keep)
(2 tuareg-font-lock-infix-extension-node-face keep)
(3 font-lock-function-name-face keep t))
;; "private" treated as governing keyword
(,(concat "\\(\\\\)"
" *\\(" lid "\\)?")
(1 tuareg-font-lock-governing-face keep t)
(2 font-lock-function-name-face keep t)); method name
(,(concat "\\<\\(open\\(?:! +\\|\\> *\\)\\)\\(" module-path "\\)?")
(1 tuareg-font-lock-governing-face)
(2 tuareg-font-lock-module-face keep t))
;; (expr: t) and (expr :> t) If `t' is longer then one
;; word, require a space before. Not only this is more
;; readable but it also avoids that `~label:expr var` is
;; taken as a type annotation when surrounded by
;; parentheses. Done last so that it does not apply if
;; already highlighted (let x : t = u in ...) but before
;; module paths (expr : X.t).
(,(concat "(" balanced-braces-no-end-operator ":>? *\\(?:\n *\\)?"
"\\(['_A-Za-z]" balanced-braces-no-string
"\\|(" balanced-braces-no-string ")"
balanced-braces-no-string"\\))")
1 font-lock-type-face)
;; module paths A.B.
(,(concat module-path "\\.") . tuareg-font-lock-module-face)
,@(and tuareg-support-metaocaml
'(("[^-@^!*=<>&/%+~?#]\\(\\(?:\\.<\\|\\.~\\|!\\.\\|>\\.\\)+\\)"
1 tuareg-font-lock-multistage-face)))
;; External function declaration
(,(concat "\\_<\\(external\\)\\_>\\(?: +\\(" lid "\\)\\)?")
(1 tuareg-font-lock-governing-face)
(2 font-lock-function-name-face keep t))
;; Binding operators
(,(concat "( *\\(\\(?:let\\|and\\)\\_>"
binding-operator-char "\\) *)")
1 font-lock-function-name-face)
;; Highlight "let" and function names (their argument
;; patterns can then be treated uniformly with variable bindings)
(,(concat let-binding-g4 " *\\(?:\\(" lid "\\) *"
"\\(?:[^ =,:a]\\|a\\(?:[^s]\\|s[^[:space:]]\\)\\)\\)?")
(1 tuareg-font-lock-governing-face keep t)
(2 tuareg-font-lock-infix-extension-node-face keep t)
(3 tuareg-font-lock-governing-face keep t)
(4 tuareg-font-lock-governing-face keep t)
(5 font-lock-function-name-face keep t))
(,(concat "\\_<\\(include\\)\\_>\\(?: +\\("
extended-module-path "\\|( *"
extended-module-path " *: *" balanced-braces " *)\\)\\)?")
(1 tuareg-font-lock-governing-face)
(2 tuareg-font-lock-module-face keep t))
;; module type A = B
(,(concat "\\_<\\(module +type\\)\\_>\\(?: +" id
" *= *\\(" modtype-path "\\)\\)?")
(1 tuareg-font-lock-governing-face)
(2 tuareg-font-lock-module-face keep t))
;; "class [params] name"
(,(concat gclass-gparams "\\(" lid "\\)?")
(1 tuareg-font-lock-governing-face keep)
(2 font-lock-type-face keep t)
(3 font-lock-function-name-face keep t))
;; "type lid" anywhere (e.g. "let f (type t) x =")
;; introduces a new type
(,(concat "\\_<\\(type\\_>\\)\\(" maybe-infix-ext+attr
"\\)\\(?: +\\(nonrec\\_>\\)\\)?\\(?:"
tuareg--whitespace-re
"\\(" typedef "\\)\\)?")
(1 tuareg-font-lock-governing-face)
(2 tuareg-font-lock-infix-extension-node-face keep)
(3 tuareg-font-lock-governing-face keep t)
(4 font-lock-type-face keep t))))
tuareg-font-lock-keywords-1-extra)
(setq
tuareg-font-lock-keywords
(append
common-keywords
`(;; Basic way of matching functions
(,(concat let-binding-g4 " *\\("
lid "\\) *= *\\(fun\\(?:ction\\)?\\)\\>")
(5 font-lock-function-name-face)
(6 font-lock-keyword-face))
)))
(setq
tuareg-font-lock-keywords-1-extra
`((,(regexp-opt '("true" "false" "__LOC__" "__FILE__" "__LINE__"
"__MODULE__" "__POS__" "__LOC_OF__" "__LINE_OF__"
"__POS_OF__")
'symbols)
. font-lock-constant-face)
(,(let ((kwd '("as" "do" "done" "downto" "else" "for" "if"
"then" "to" "try" "when" "while" "new"
"lazy" "assert" "exception")))
(if (tuareg-editing-ls3)
(progn (push "reset" kwd) (push "merge" kwd)
(push "emit" kwd) (push "period" kwd)))
(regexp-opt kwd 'symbols))
. font-lock-keyword-face)
(,(concat "\\_"
balanced-braces "\\)?\\) *)")
1 tuareg-font-lock-module-face keep)
;; module A(B: _)(C: _) : D = E, including "module A : E"
(,(concat "\\_" balanced-braces "\\)?"
" *)" tuareg--whitespace-re "\\)*\\)\\(?::"
tuareg--whitespace-re "\\(" modtype-path
"\\) *\\)?\\(?:=" tuareg--whitespace-re
"\\(" extended-module-path "\\)\\)?")
(1 font-lock-variable-name-face keep); functor (module) variable
(2 tuareg-font-lock-module-face keep t)
(3 tuareg-font-lock-module-face keep t))
(,(concat "\\_ *( *\\(" uid "\\) *: *\\("
modtype-path "\\) *)")
(1 font-lock-variable-name-face keep); functor (module) variable
(2 tuareg-font-lock-module-face keep))
;; Other uses of "with", "mutable", "private", "virtual"
(,(regexp-opt '("of" "with" "mutable" "private" "virtual") 'symbols)
. font-lock-keyword-face)
;; labels
(,(concat "\\([?~]" lid "\\)" tuareg--whitespace-re ":[^:>=]")
1 tuareg-font-lock-label-face keep)
;; label in a type signature
(,(concat "\\(?:->\\|:[^:>=]\\)" tuareg--whitespace-re
"\\(" lid "\\)[ \t]*:[^:>=]")
1 tuareg-font-lock-label-face keep)
;; Polymorphic variants (take precedence on builtin names)
(,(concat "`" id) . tuareg-font-lock-constructor-face)
(,(regexp-opt '("failwith" "failwithf" "exit" "at_exit" "invalid_arg"
"parser" "raise" "raise_notrace" "ref" "ignore"
"Match_failure" "Assert_failure" "Invalid_argument"
"Failure" "Not_found" "Out_of_memory" "Stack_overflow"
"Sys_error" "End_of_file" "Division_by_zero"
"Sys_blocked_io" "Undefined_recursive_module")
'symbols)
. font-lock-builtin-face)
("\\[[ \t]*\\]" . tuareg-font-lock-constructor-face) ; []
("[])a-zA-Z0-9 \t]\\(::\\)[[(a-zA-Z0-9 \t]" ; :: (not not ::…)
1 tuareg-font-lock-constructor-face)
;; Constructors
(,(concat "\\(" uid "\\)[^.]") 1 tuareg-font-lock-constructor-face)
(,(concat "\\_")
(5 font-lock-function-name-face nil t)
(6 font-lock-type-face keep t))
;; let binding variables
(,(concat "\\(?:" let-binding-g4 "\\|" gclass-gparams "\\)")
(tuareg--pattern-vars-matcher (tuareg--pattern-pre-form-let) nil
(0 font-lock-variable-name-face keep))
(tuareg--pattern-maybe-type-matcher nil nil ; def followed by type
(1 font-lock-type-face keep)))
(,(concat "\\_" maybe-infix-ext+attr)
(tuareg--pattern-vars-matcher (tuareg--pattern-pre-form-fun) nil
(0 font-lock-variable-name-face keep)))
(,(concat "\\_@^|&+*/$%!]" operator-char
"*\\|[#?~]" operator-char "+\\) *)")
1 font-lock-function-name-face)
;; By default do no highlight relation operators (=, <, >) nor
;; arithmetic operators because it is slow. However,
;; optionally allow it by popular demand.
,@(if tuareg-highlight-all-operators
;; Highlight "@", "+",... after "let…[@…]" but before
;; "let" rules remove the highlighting of "=".
`((,(concat before-operator-char
"\\([=<>@^&+*/$%!]" operator-char "*\\|:=\\|"
"[|#?~]" operator-char "+\\)")
1 tuareg-font-lock-operator-face)
;; "-" is special: avoid "->" and "-13"
(,(concat "\\(-\\)\\(?:[^0-9>]\\|\\("
operator-char-no> operator-char "*\\)\\)")
(1 tuareg-font-lock-operator-face)
(2 tuareg-font-lock-operator-face keep t))
(,(regexp-opt '("type" "module" "module type"
"val" "val mutable")
'symbols)
(tuareg--pattern-equal-matcher nil nil nil)))
`((,(concat "[@^&$%!]" operator-char "*\\|"
"[|#?~]" operator-char "+")
. tuareg-font-lock-operator-face)))
(,(regexp-opt
(if (tuareg-editing-ls3)
'("asr" "asl" "lsr" "lsl" "or" "lor" "and" "land" "lxor"
"not" "lnot" "mod" "fby" "pre" "last" "at")
'("asr" "asl" "lsr" "lsl" "or" "lor" "land"
"lxor" "not" "lnot" "mod"))
'symbols)
1 tuareg-font-lock-operator-face)
,@tuareg-font-lock-keywords-1-extra)))
(setq font-lock-defaults
`((tuareg-font-lock-keywords
tuareg-font-lock-keywords-1
tuareg-font-lock-keywords-2)
nil nil
,tuareg-font-lock-syntax nil
(font-lock-syntactic-face-function
. tuareg-font-lock-syntactic-face-function)))
;; (push 'smie-backward-sexp-command font-lock-extend-region-functions)
)
(defvar tuareg--pattern-matcher-limit 0
"Limit for the matcher of function arguments")
(make-variable-buffer-local 'tuareg--pattern-matcher-limit)
(defvar tuareg--pattern-matcher-type-limit 0
"Limit for the type of a let bound definition.")
(make-variable-buffer-local 'tuareg--pattern-matcher-type-limit)
(defun tuareg--font-lock-in-string-or-comment ()
"Returns t if the point is inside a string or a comment.
This based on the fontification and is faster than calling `syntax-ppss'.
It must not be used outside fontification purposes."
(let* ((face (get-text-property (point) 'face)))
(and (symbolp face)
(memq face '(font-lock-comment-face
font-lock-comment-delimiter-face
font-lock-doc-face
tuareg-font-lock-doc-markup-face
tuareg-font-lock-doc-verbatim-face
font-lock-string-face)))))
(defun tuareg--pattern-pre-form-let ()
"Return the position of \"=\" marking the end of \"let\"."
(if (or (tuareg--font-lock-in-string-or-comment)
(looking-at "[ \t\n]*open\\_>") ; "let open"
(looking-at "[ \t\n]*exception\\_>")) ; "let exception"
(progn ; bail out
(setq tuareg--pattern-matcher-limit (point))
(setq tuareg--pattern-matcher-type-limit (point)))
(let* ((opoint (point))
(limit (+ opoint 800))
pos)
(setq tuareg--pattern-matcher-limit nil)
(while (and
(setq pos (re-search-forward "[=({:]" limit t))
(progn
(backward-char)
(cond
((memq (char-after) '(?\( ?\{))
;; Skip balanced braces
(if (ignore-errors (forward-list))
t
(goto-char (1- pos))
nil)) ; If braces are not balanced, stop.
((char-equal ?: (char-after))
;; Make sure it is not a label
(skip-chars-backward "a-zA-Z0-9_'")
(if (not (memq (char-before) '(?~ ??)))
(setq tuareg--pattern-matcher-limit (1- pos)))
(goto-char pos)
t)
(t nil)))))
(setq tuareg--pattern-matcher-type-limit (1+ (point))); include "="
(unless tuareg--pattern-matcher-limit
(setq tuareg--pattern-matcher-limit (point)))
;; Remove any possible highlighting on "="
(unless (eobp)
(put-text-property (point) (1+ (point)) 'face nil))
;; move the point back for the sub-matcher
(goto-char opoint))
(put-text-property (point) tuareg--pattern-matcher-limit
'font-lock-multiline t)
tuareg--pattern-matcher-limit))
(defun tuareg--pattern-pre-form-fun ()
"Return the position of \"->\" marking the end of \"fun\"."
(if (tuareg--font-lock-in-string-or-comment)
(setq tuareg--pattern-matcher-limit (point))
(let* ((opoint (point))
(limit (+ opoint 800))
pos)
(while (and
(setq pos (re-search-forward "[-({]" limit t))
(cond
((or (char-equal ?\( (char-before))
(char-equal ?{ (char-before)))
(backward-char)
(if (ignore-errors (forward-list))
t
(goto-char (1- pos))
nil)) ; If braces are not balanced, stop.
(t (not (char-equal ?> (char-after)))))))
(setq tuareg--pattern-matcher-limit (point))
;; move the point back for the sub-matcher
(goto-char opoint)
(put-text-property (point) tuareg--pattern-matcher-limit
'font-lock-multiline t))
tuareg--pattern-matcher-limit))
(defun tuareg--pattern-equal-matcher (limit)
"Find \"=\" and \"+=\" and remove its highlithing."
(unless (tuareg--font-lock-in-string-or-comment)
(let (pos)
(while (and
(<= (point) limit)
(setq pos (re-search-forward "[+=({[]" limit t))
(progn
(backward-char)
(cond
((or (char-equal ?\( (char-after))
(char-equal ?{ (char-after))
(char-equal ?\[ (char-after)))
;; Skip balanced braces
(if (ignore-errors (forward-list))
t
(goto-char (1- pos))
nil)) ; If braces are not balanced, stop.
((char-equal ?+ (char-after))
(if (char-equal ?= (char-after pos))
(put-text-property (point) (1+ pos) 'face nil)
(forward-char)
t))
(t
(put-text-property (point) (1+ (point)) 'face nil))))))
nil)))
(defun tuareg--pattern-vars-matcher (_limit)
"Match a variable name after the point.
If it succeeds, it moves the point after the variable name and set
`match-data'. See e.g., `font-lock-keywords'."
(when (and (<= (point) tuareg--pattern-matcher-limit)
(re-search-forward tuareg--lid-re tuareg--pattern-matcher-limit t))
(skip-chars-forward " \t\n")
(if (>= (point) tuareg--pattern-matcher-limit)
t
(cond
((char-equal ?= (char-after))
;; Remove possible fontification of "=" (e.g. as an operator)
(put-text-property (point) (1+ (point)) 'face nil)
;; Decide whether it is ?(v =...) or {x = v; x = v}
(goto-char (match-beginning 0))
(skip-chars-backward " \t\n")
(if (char-equal (char-before) ?\() ; (var = expr)
(progn (up-list) ; keep match, skip expr
t)
;; This is a label record, variable after
(goto-char (match-end 0))
(re-search-forward tuareg--lid-re tuareg--pattern-matcher-limit t)))
((char-equal ?: (char-after))
(let ((beg-ty (1+ (point))))
(goto-char (match-beginning 0))
(skip-chars-backward " \t\n")
(if (char-equal (char-before) ?\() ; (var : t)
(progn
(up-list) ; keep match, skip type
(put-text-property beg-ty (1- (point)) 'face
'font-lock-type-face)
t)
(goto-char (match-end 0)))))
(t t)))))
(defun tuareg--pattern-maybe-type-matcher (limit)
"Match a possible type after a let binding.
Run only once."
;; This function is needed because we want to ensure that the search
;; is bounded by the detected "=".
(when (and (<= (point) tuareg--pattern-matcher-type-limit)
(re-search-forward "[ \t\n]*:\\([^=]+\\)="
tuareg--pattern-matcher-type-limit t))
(goto-char limit) ; Do not run a second time
t))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Keymap
;; Functions from the caml-mode package that may or may not be
;; available during compilation.
(declare-function caml-help "caml-help" (arg))
(declare-function ocaml-open-module "caml-help" (arg))
(declare-function ocaml-close-module "caml-help" (arg))
(declare-function ocaml-add-path "caml-help" (dir &optional path))
(declare-function caml-types-explore "caml-types" (event))
(declare-function caml-types-mouse-ignore "caml-types" (event))
(declare-function caml-types-show-ident "caml-types" (arg))
(declare-function caml-types-show-call "caml-types" (arg))
(declare-function caml-types-show-type "caml-types" (arg))
(defvar tuareg-mode-map
(let ((map (make-sparse-keymap)))
(define-key map "\M-q" #'tuareg-indent-phrase)
(define-key map [?\C-c ?\C-\;] #'tuareg-comment-dwim)
(define-key map "\C-c\C-q" #'tuareg-indent-phrase)
(define-key map "\C-c\C-a" #'tuareg-find-alternate-file)
(define-key map "\C-c\C-c" #'compile)
(define-key map "\C-c\C-w" #'tuareg-opam-update-env)
(define-key map "\M-\C-x" #'tuareg-eval-phrase)
(define-key map "\C-x\C-e" #'tuareg-eval-phrase)
(define-key map "\C-c\C-e" #'tuareg-eval-phrase)
(define-key map "\C-c\C-r" #'tuareg-eval-region)
(define-key map "\C-c\C-b" #'tuareg-eval-buffer)
(define-key map "\C-c\C-s" #'tuareg-run-ocaml)
(define-key map "\C-c\C-z" #'tuareg-switch-to-repl)
(define-key map "\C-c\C-i" #'tuareg-interrupt-ocaml)
(define-key map "\C-c\C-k" #'tuareg-kill-ocaml)
(define-key map "\C-c`" #'tuareg-interactive-next-error-source)
(define-key map "\C-c?" #'tuareg-interactive-next-error-source)
(define-key map "\C-c.c" #'tuareg-insert-class-form)
(define-key map "\C-c.b" #'tuareg-insert-begin-form)
(define-key map "\C-c.f" #'tuareg-insert-for-form)
(define-key map "\C-c.w" #'tuareg-insert-while-form)
(define-key map "\C-c.i" #'tuareg-insert-if-form)
(define-key map "\C-c.l" #'tuareg-insert-let-form)
(define-key map "\C-c.m" #'tuareg-insert-match-form)
(define-key map "\C-c.t" #'tuareg-insert-try-form)
(when tuareg-with-caml-mode-p
;; Trigger caml-types
(define-key map [?\C-c ?\C-t] #'caml-types-show-type) ; "type"
(define-key map [?\C-c ?\C-f] #'caml-types-show-call) ; "function"
(define-key map [?\C-c ?\C-l] #'caml-types-show-ident) ; "let"
;; To prevent misbehavior in case of error during exploration.
(define-key map [?\C-c mouse-1] #'caml-types-mouse-ignore)
(define-key map [?\C-c down-mouse-1] #'caml-types-explore)
;; Trigger caml-help
(define-key map [?\C-c ?\C-i] #'ocaml-add-path)
(define-key map [?\C-c ?\[] #'ocaml-open-module)
(define-key map [?\C-c ?\]] #'ocaml-close-module)
(define-key map [?\C-c ?\C-h] #'caml-help)
(define-key map [?\C-c ?\t] #'tuareg-complete))
map)
"Keymap used in Tuareg mode.")
(defvar tuareg-electric-indent-keywords
'("module" "class" "functor" "object" "type" "val" "inherit"
"include" "virtual" "constraint" "exception" "external" "open"
"method" "and" "initializer" "to" "downto" "do" "done" "else"
"begin" "end" "let" "in" "then" "with"))
(defun tuareg--electric-indent-predicate (char)
"Check whether we should auto-indent.
For use on `electric-indent-functions'."
(save-excursion
(tuareg-backward-char);; Go before the inserted char.
(let ((syntax (char-syntax char)))
(if (tuareg-in-indentation-p)
(or (eq char ?|) (eq syntax ?\)))
(or (pcase char
(`?\) (char-equal ?* (preceding-char)))
(`?\} (and (char-equal ?> (preceding-char))
(progn (tuareg-backward-char)
(tuareg-in-indentation-p))))
(`?\] (and (char-equal ?| (preceding-char))
(progn (tuareg-backward-char)
(tuareg-in-indentation-p)))))
(and tuareg-electric-indent
(not (eq syntax ?w))
(let ((end (point)))
(skip-syntax-backward "w_")
(member (buffer-substring (point) end)
tuareg-electric-indent-keywords))
(tuareg-in-indentation-p)))))))
(defun tuareg--electric-close-vector ()
;; Function for use on post-self-insert-hook.
(when tuareg-electric-close-vector
(let ((inners (cdr (assq last-command-event
'((?\} ?> "{<") (?\] ?| "\\[|"))))))
(and inners
(eq (char-before) last-command-event) ;; Sanity check.
(not (eq (car inners) (char-before (1- (point)))))
(not (tuareg-in-literal-or-comment-p))
(save-excursion
(when (ignore-errors (backward-sexp 1) t)
(looking-at (nth 1 inners))))
(save-excursion
(goto-char (1- (point)))
(insert (car inners)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SMIE
;; TODO:
;; - Obey tuareg-*-indent customization variables.
;; - Fix use of tuareg-indent-command in tuareg-auto-fill-insert-leading-star.
;; - Use it by default (when possible).
;; - Move the old indentation code to a separate file.
(defconst tuareg-smie-grammar
;; Problems:
;; - "let D in E" expression vs "let D" declaration. This is solved
;; by making the lexer return "d-let" for the second case.
;; - FIXME: SMIE assumes that concatenation binds tighter than
;; everything else, whereas OCaml gives tighter precedence to ".".
;; - "x : t1; (y : (t2 -> t3)); z : t4" but
;; "when (x1; x2) -> (z1; z2)". We solve this by distinguishing
;; the two kinds of arrows, using "t->" for the type arrow.
;; - The "with" in modules's "with type" has different precedence.
;; - Big problem with "if...then": because of SMIE's transitivity of the
;; precedence relation, we can't properly parse both "if A then B; C" and
;; "if A then let x = E in B; C else D" (IOW I think a non-transitive OPG
;; could do it). We could try and fix the problem in the lexer, but it's
;; far from obvious how (we'd probably end up having to pre-parse the text
;; in the lexer to decide which kind of "if" and "then" we're looking
;; at). A good solution could be found maybe if SMIE let us disambiguate
;; lexemes late, i.e. at a time where we have access to the relevant parse
;; stack. Or maybe by allowing smie-grammar to use a non-transitive
;; precedence relation. But until that happens, we will live with an
;; incorrect parse, and instead we try to patch up the result with ad-hoc
;; hacks in tuareg-smie-rules.
;; - The " with " syntax introduces many
;; conflicts:
;; "... with module M = A with module B = C"
;; vs "... module M = A with module B = C"
;; In the first, the second "with" should either have the first "with" as
;; sibling, or have some earlier construct as parent, whereas in the second
;; the "with" should have the first "=" (or maybe the first "module", tho
;; that would not correspond to the actual language syntax and would
;; probably break other cases) as parent. Other problems in this
;; mod-constraints syntax: we need a precedence along the lines of
;; "with" < "and" < "module/type", whereas the rest of the syntax wants
;; "module/type" < "and" < "with", so basically all the keywords involved
;; in mod-constraints need to be handled specially in the lexer :-(
;; - and then some...
(let ((bnfprec2
(smie-bnf->prec2
'((decls (decls "type" decls) (decls "d-let" decls)
(decls "and" decls) (decls ";;" decls)
(decls "exception" decls)
(decls "module" decls)
(decls "class" decls)
(decls "val" decls) (decls "external" decls)
(decls "open" decls) (decls "include" decls)
(exception)
(def)
;; Hack: at the top-level, a "let D in E" can appear in
;; decls as well, but the lexer classifies it as "d-let",
;; so we need to make sure that "d-let D in E" doesn't
;; end up matching the "in" with some far away thingy.
(def-in-exp))
(def-in-exp (defs "in" exp))
(def (var "d=" exp) (id "d=" datatype) (id "d=" module))
(idtype (id ":" type))
(var (id) ("m-type" var) ("d-type" var) ("c-type" var) ("rec" var)
("private" var) (idtype)
("l-module" var) ("l-class" var))
(exception (id "of" type))
(datatype ("{" typefields "}") (typebranches)
(typebranches "with" id))
(typebranches (typebranches "|" typebranches) (id "of" type))
(typefields (typefields ";" typefields) (idtype))
(type (type "*…" type) (type "t->" type)
;; ("<" ... ">") ;; FIXME!
(type "as" id))
(id)
(module ("struct" decls "end")
("sig" decls "end")
("functor" id "->" module)
(module "m-with" mod-constraints))
(simpledef (id "c=" type))
(mod-constraints (mod-constraints "m-and" mod-constraints)
("w-type" simpledef)
("w-module" simpledef))
;; https://v2.ocaml.org/manual/expr.html
;; exp1 is "all exps except for `if exp then'".
(exp1 ("begin" exp "end")
("(" exp:type ")")
("[|" exp "|]")
("{" fields "}")
("if" exp "then" exp1 "else" exp1)
;; ("if" exp "then" exp)
("while" exp "do" exp "done")
("for" forbounds "do" exp "done")
(exp1 ";" exp1)
("match" exp "with" branches)
("function" branches)
("fun" patterns* "->" exp1)
("try" exp "with" branches)
("let" defs "in" exp1)
("let" "exception-let" exception "in" exp1)
("object" class-body "end")
("(" exp:>type ")")
("{<" fields ">}")
;; MetaOCaml thingies.
;; Let's not do anything special for .~ for now,
;; as for !. it's deprecated anyway!
(".<" exp ">."))
;; Like `exp' but additionally allow if-then without else.
(exp (exp1) ("if" exp "then" exp))
(forbounds (iddef "to" exp) (iddef "downto" exp))
(defs (def) (defs "and" defs) ("l-open" id))
(exp:>type (exp:type ":>" type))
(exp:type (exp)) ;; (exp ":" type)
(fields (fields1) (exp "with" fields1))
(fields1 (fields1 ";" fields1) (iddef))
(iddef (id "f=" exp1))
(branches (branches "|" branches) (branch))
(branch (patterns "->" exp1))
(patterns* ("-dlpd-" patterns*) (patterns)) ;See use of "-dlpd-".
(patterns (pattern) (pattern "when" exp1)
;; Since OCaml 4.02, `match' expressions allow
;; `exception' branches.
("exception-case" pattern))
(pattern (id) (pattern "as" id) (pattern "|-or" pattern)
(pattern "," pattern))
(class-body (class-body "inherit" class-body)
(class-body "method" class-body)
(class-body "initializer" class-body)
(class-body "val" class-body)
(class-body "constraint" class-body)
(class-field))
(class-field (exp) ("mutable" idtype)
("virtual" idtype) ("private" idtype))
;; We get cyclic dependencies between ; and | because things like
;; "branches | branches" implies that "; > |" whereas "exp ; exp"
;; implies "| > ;" and while those two do not directly conflict
;; because they're constraints on precedences of different sides,
;; they do introduce a cycle later on because those operators are
;; declared associative, which adds a constraint that both sides
;; must be of equal precedence. So we declare here a dummy rule
;; to force a direct conflict, that we can later resolve with
;; explicit precedence rules.
(foo1 (foo1 ";" foo1) (foo1 "|" foo1))
;; "mutable x : int ; y : int".
(foo2 ("mutable" id) (foo2 ";" foo2))
)
;; Type precedence rules.
;; https://v2.ocaml.org/manual/types.html
'((nonassoc "as") (assoc "t->") (assoc "*…"))
;; Pattern precedence rules.
;; https://v2.ocaml.org/manual/patterns.html
'((nonassoc "as") (assoc "|-or") (assoc ",") (assoc "::"))
;; Resolve "{a=(1;b=2)}" vs "{(a=1);(b=2)}".
'((nonassoc ";") (nonassoc "f="))
;; Resolve "(function a -> b) | c -> d".
'((nonassoc "function") (nonassoc "|"))
;; Resolve "when (function a -> b) -> c".
'((nonassoc "function") (nonassoc "->"))
;; Resolve ambiguity "(let d in e2); e3" vs "let d in (e2; e3)".
'((nonassoc "in" "match" "->" "with") (nonassoc ";"))
;; Resolve "(if a then b else c);d" vs "if a then b else (c; d)".
'((nonassoc ";") (nonassoc "else")) ;; ("else" > ";")
;; Resolve "match e1 with a → (match e2 with b → e3 | c → e4)"
;; vs "match e1 with a → (match e2 with b → e3) | c → e4"
'((nonassoc "with") (nonassoc "|"))
;; Resolve "functor A -> (M with MC)".
'((nonassoc "->") (nonassoc "m-with"))
;; Resolve the conflicts caused by "when" and by SMIE's assumption
;; that all non-terminals can match the empty string.
'((nonassoc "with") (nonassoc "->")) ; "when (match a with) -> e"
'((nonassoc "|") (nonassoc "->")) ; "when (match a with a|b) -> e"
;; Fix up conflict between (decls "and" decls) and (defs "in" exp).
'((nonassoc "in") (nonassoc "and"))
;; Resolve the "artificial" conflict introduced by the `foo1' rule.
'((assoc "|") (assoc ";"))
;; Fix up associative declaration keywords.
'((assoc "type" "d-let" "exception" "module" "val" "open"
"external" "include" "class" ";;")
(assoc "and"))
'((assoc "val" "method" "inherit" "constraint" "initializer"))
;; Declare associativity of remaining sequence separators.
'((assoc ";")) '((assoc "|")) '((assoc "m-and")))))
;; (dolist (pair '()) ;; ("then" . "|") ("|" . "then")
;; (display-warning 'prec2 (format "%s %s %s"
;; (car pair)
;; (gethash pair bnfprec2)
;; (cdr pair))))
;; SMIE takes for granted that all non-terminals can match the empty
;; string, which can lead to the addition of unnecessary constraints.
;; Let's remove the ones that cause cycles without causing conflicts.
(progn
;; This comes from "exp ; exp" and "function branches", where
;; SMIE doesn't realize that `branches' has to have a -> before ;.
(cl-assert (eq '> (gethash (cons "function" ";") bnfprec2)))
(remhash (cons "function" ";") bnfprec2))
(smie-prec2->grammar
(smie-merge-prec2s
bnfprec2
(smie-precs->prec2
;; Precedence of operators.
;; https://v2.ocaml.org/manual/expr.html
(reverse
'((nonassoc ".")
;; function application, constructor application, assert, lazy
;; - -. (prefix) –
(right "**…" "lsl" "lsr" "asr")
(nonassoc "*…" "/…" "%…" "mod" "land" "lor" "lxor")
(left "+…" "-…")
(assoc "::")
(right "@…" "^…")
(left "=…" "<…" ">…" "|…" "&…" "$…")
(right "&" "&&")
(right "or" "||")
(assoc ",")
(right "<-" ":=")
(assoc ";"))))))))
(defun tuareg-smie--search-backward (tokens)
(let (tok)
(while (progn
(setq tok (tuareg-smie--backward-token))
(if (not (zerop (length tok)))
(not (member tok tokens))
(unless (bobp)
(condition-case err
(progn (backward-sexp) t)
(scan-error
(setq tok (buffer-substring (nth 3 err) (1+ (nth 3 err))))
nil))))))
tok))
(defun tuareg-smie--search-forward (tokens)
(let (tok)
(while (progn
(setq tok (tuareg-smie--forward-token))
(if (not (zerop (length tok)))
(not (member tok tokens))
(unless (eobp)
(condition-case err
(progn (forward-sexp) t)
(scan-error
(setq tok (buffer-substring (nth 2 err) (nth 3 err)))
nil))))))
tok))
(defun tuareg-skip-blank-and-comments ()
(forward-comment (point-max)))
(defconst tuareg-smie--type-label-leader
'("->" ":" "=" ""))
(defconst tuareg-smie--exp-operator-leader
(delq nil (mapcar (lambda (x) (if (numberp (nth 2 x)) (car x)))
tuareg-smie-grammar)))
(defconst tuareg-smie--float-re "[0-9]+\\(?:\\.[0-9]*\\)?\\(?:e[-+]?[0-9]+\\)")
(defun tuareg-smie--forward-token ()
(tuareg-skip-blank-and-comments)
(let ((start (point))
(end nil))
(if (zerop (skip-syntax-forward "."))
(let ((start (point)))
(skip-syntax-forward "w_'")
;; Watch out for floats!
(and (memq (char-after) '(?- ?+))
(eq (char-before) ?e)
(save-excursion
(goto-char start)
(looking-at tuareg-smie--float-re))
(goto-char (match-end 0))))
;; The "." char is given symbol property so that "M.x" is
;; considered as a single symbol, but in reality, it's part of the
;; operator chars, since "+." and friends are operators.
(while (not (and (zerop (skip-chars-forward "."))
(zerop (skip-syntax-forward ".")))))
(when (and (eq (char-before) ?%)
(looking-at "[[:alpha:]]+"))
;; Infix extension nodes, bug#121
(setq end (1- (point)))
(goto-char (match-end 0))))
(buffer-substring-no-properties start (or end (point)))))
(defun tuareg-smie--backward-token ()
(forward-comment (- (point)))
(let ((end (point)))
(if (and (zerop (skip-chars-backward "."))
(zerop (skip-syntax-backward ".")))
(progn
(skip-syntax-backward "w_'")
;; Watch out for floats!
(pcase (char-before)
((or `?- `?+)
(and (memq (char-after) '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?0))
(save-excursion
(forward-char -1) (skip-syntax-backward "w_")
(looking-at tuareg-smie--float-re))
(>= (match-end 0) (point))
(goto-char (match-beginning 0))))
(`?% ;extension node, bug#121
(let ((pos (point)))
(forward-char -1)
(if (and (zerop (skip-chars-backward "."))
(zerop (skip-syntax-backward ".")))
(goto-char pos)
(setq end (1- pos)))))))
(cond
((memq (char-after) '(?\; ?,)) nil) ; ".;" is not a token.
((and (eq (char-after) ?\.)
(memq (char-before) '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 ?0)))
(skip-chars-backward "0-9")) ; A float number!
(t ;; The "." char is given symbol property so that "M.x" is
;; considered as a single symbol, but in reality, it's part of
;; the operator chars, since "+." and friends are operators.
(while (not (and (zerop (skip-chars-backward "."))
(zerop (skip-syntax-backward "."))))))))
(buffer-substring-no-properties (point) end)))
(defun tuareg-smie-forward-token ()
"Move point to the end of the next token and return its SMIE name."
(let ((tok (tuareg-smie--forward-token)))
(cond
((zerop (length tok))
(if (not (looking-at "{<\\|\\[|"))
tok
(goto-char (match-end 0))
(match-string 0)))
((and (equal tok "|") (looking-at-p "\\]")) (forward-char 1) "|]")
((and (equal tok ">") (looking-at-p "}")) (forward-char 1) ">}")
((and (equal tok ".") (memq (char-after) '(?< ?~)))
(forward-char 1) (string ?. (char-before)))
((or (member tok '("let" "=" "->"
"module" "class" "open" "type" "with" "and"
"exception"))
;; https://v2.ocaml.org/manual/expr.html lists
;; the tokens whose precedence is based on their prefix.
(memq (aref tok 0) '(?* ?/ ?% ?+ ?- ?@ ?^ ?= ?< ?> ?| ?& ?$)))
;; When indenting, the movement is mainly backward, so it's OK to make
;; the forward tokenizer a bit slower.
(save-excursion (tuareg-smie-backward-token)))
((and (member tok '("~" "?"))
(looking-at "[[:alpha:]_][[:alnum:]'_]*:"))
(goto-char (match-end 0))
"label:")
((and (looking-at-p ":\\(?:[^:]\\|\\'\\)")
(string-match-p "\\`[[:alpha:]_]" tok)
(save-excursion
(tuareg-smie--backward-token) ;Go back.
(member (tuareg-smie--backward-token)
tuareg-smie--type-label-leader)))
(forward-char 1)
"label:")
((string-match-p "\\`[[:alpha:]_].*\\.\\'" tok)
(forward-char -1) (substring tok 0 -1))
(t tok))))
(defconst tuareg-smie--exp-leaders
;; (let ((leaders ()))
;; (dolist (cat tuareg-smie-bnf)
;; (dolist (rule (cdr cat))
;; (setq rule (reverse rule))
;; (while (setq rule (cdr (cl-member 'dummy rule
;; :test (lambda (_ x)
;; (memq x '(exp exp1))))))
;; (push (car rule) leaders))))
;; (prin1-to-string (sort (delete-dups leaders) #'string-lessp)))
;; BEWARE: In let-disambiguate, we compare this against the output of
;; tuareg-smie--backward-token which never returns refined tokens like "d=",
;; so we manually replace those with just "=" here!
'("->" ".<" ";" "[|" "begin" "=" "do" "downto" "else" "if" "in"
"match" "then" "to" "try" "when" "while"))
(defun tuareg-smie--let-disambiguate ()
"Return \"d-let\" if \"let\" at point is a decl, or just \"let\" if it's an exp."
(save-excursion
(let ((prev (tuareg-smie--backward-token)))
(if (or (member prev tuareg-smie--exp-leaders)
(if (zerop (length prev))
(and (not (bobp))
;; See if prev char has open-paren syntax.
(eq 4 (mod (car (syntax-after (1- (point)))) 256)))
(and (eq ?. (char-syntax (aref prev 0)))
(and (not (equal prev ";;"))
(let ((tokinfo (assoc prev smie-grammar)))
;; Check that prev is not a closing token like ">."
(or (null tokinfo)
(integerp (nth 2 tokinfo))))))))
"let"
"d-let"))))
(defun tuareg-smie--label-colon-p ()
(and (not (zerop (skip-chars-backward "[:alnum:]_")))
(or (not (zerop (skip-chars-backward "?~")))
(save-excursion
(member (tuareg-smie--backward-token)
tuareg-smie--type-label-leader)))))
(defun tuareg-smie--=-disambiguate ()
"Return which kind of \"=\" we've just found.
Point is not moved and should be right in front of the equality.
Return values can be
\"f=\" for field definition,
\"d=\" for a normal definition,
\"c=\" for a type equality constraint, and
\"=…\" for an equality test."
(save-excursion
(let* ((pos (point))
(telltale '("type" "let" "module" "class" "and" "external"
"val" "method" "=" ":="
"if" "then" "else" "->" ";" ))
(nearest (tuareg-smie--search-backward telltale)))
(cond
((and (member nearest '("{" ";"))
(let ((field t))
(while
(let ((x (tuareg-smie--forward-token)))
(and (< (point) pos)
(cond
((zerop (length x)) (setq field nil))
((memq (char-syntax (aref x 0)) '(?w ?_)))
((member x '("." ";")))
(t (setq field nil))))))
field))
"f=")
((progn
(while (and (equal nearest "->")
(save-excursion
(forward-char 2)
(equal (tuareg-smie-backward-token) "t->")))
(setq nearest (tuareg-smie--search-backward telltale)))
nil))
((and (member nearest '("=" ":="))
(member (tuareg-smie--search-backward telltale)
'("type" "module")))
;; Second equality in "type t = M.t = C" or after mod-constraint
"d=")
((not (member nearest '("type" "let" "module" "class" "and"
"external" "val" "method")))
"=…")
((and (member nearest '("type" "module"))
;; Maybe a module's type equality constraint?
(or (member (tuareg-smie--backward-token) '("with" "and"))
;; Or maybe an alias as part of a definition?
(and (equal nearest "type")
(goto-char (1+ pos)) ;"1+" to skip the `=' itself!
(let ((tok (tuareg-smie--search-forward
(cons "=" (mapcar #'car
tuareg-smie-grammar)))))
(equal tok "=")))))
"c=")
(t "d=")))))
(defun tuareg-smie--:=-disambiguate ()
"Return which kind of \":=\" we've just found.
Point is not moved and should be right in front of the equality.
Return values can be
\":=\" for assignment definition,
\"c=\" for destructive equality constraint."
(save-excursion
(let* ((telltale '("type" "let" "module" "class" "and" "external"
"val" "method" "=" ":="
"if" "then" "else" "->" ";" ))
(nearest (tuareg-smie--search-backward telltale)))
(cond ;Issue #7
((and (member nearest '("type" "module"))
(member (tuareg-smie--backward-token) '("with" "and"))) "c=")
(t ":=")))))
(defun tuareg-smie--|-or-p ()
"Return non-nil if we're just in front of an or pattern \"|\"."
(save-excursion
(let ((tok (tuareg-smie--search-backward
;; Stop at the first | or any token which should
;; never appear between a "|" and a "|-or".
'("|" "[" "->" "with" "function" "=" "of" "in" "then"))))
(cond
((equal tok "(") t)
((equal tok "|")
;; Maybe we have a "|-or". Then again maybe not. We should make sure
;; that `tok' is really either a "|-or" or the | of a match (and not
;; the | of a datatype definition).
(while
(equal "|"
(setq tok
(tuareg-smie--search-backward
'("|" "with" "function" "=" "of" "in" "then")))))
(cond
((equal tok "=")
(not (equal (tuareg-smie--=-disambiguate) "d=")))
((equal tok "of") nil)
((member tok '("[" "{" "(")) nil)
(t t)))))))
(defun tuareg-smie-backward-token ()
"Move point to the beginning of the previous token and return its SMIE name."
(let ((tok (tuareg-smie--backward-token)))
(cond
;; Distinguish a let expression from a let declaration.
((equal tok "let") (tuareg-smie--let-disambiguate))
((equal ".<.~" tok) (forward-char 2) ".~") ;FIXME: Likely too ad-hoc!
;; Handle "let module" and friends.
((member tok '("module" "class" "open"))
(let ((prev (save-excursion (tuareg-smie--backward-token))))
(cond
((equal prev "let") (concat "l-" tok))
((and (member prev '("with" "and")) (equal tok "module")) "w-module")
(t tok))))
;; Distinguish a "type ->" from a "case ->".
((equal tok "->")
(save-excursion
(let (nearest)
(while (progn
(setq nearest (tuareg-smie--search-backward
'("with" "|" "fun" "function" "functor"
"type" ":" "of")))
(and (equal nearest ":")
(tuareg-smie--label-colon-p))))
(if (member nearest '("with" "|" "fun" "function" "functor"))
tok "t->"))))
;; Handle "module type", "class type", mod-constraint's "with/and type"
;; and polymorphic syntax.
((equal tok "type")
(save-excursion
(let ((prev (tuareg-smie--backward-token)))
(cond ((equal prev "module") "m-type")
((equal prev "class") "c-type")
((member prev '("and" "with")) "w-type")
((equal prev ":") "d-type"); ": type a. ..."
(t tok)))))
;; Disambiguate mod-constraint's "and" and "with".
((member tok '("with" "and"))
(save-excursion
(tuareg-smie--forward-token)
(if (member (tuareg-smie--forward-token) '("type" "module"))
(concat "m-" tok) tok)))
;; Distinguish a defining = from a comparison-=.
((equal tok "=")
(tuareg-smie--=-disambiguate))
((equal tok ":=") (tuareg-smie--:=-disambiguate))
((zerop (length tok))
(if (not (and (memq (char-before) '(?\} ?\]))
(save-excursion (forward-char -2)
(looking-at ">}\\||\\]"))))
tok
(goto-char (match-beginning 0))
(match-string 0)))
((and (equal tok "|") (eq (char-before) ?\[)) (forward-char -1) "[|")
((and (equal tok "<") (eq (char-before) ?\{)) (forward-char -1) "{<")
((equal tok "|")
;; Check if it's the | of an or-pattern, since it has a slightly
;; different precedence (see Issue #71 for an example).
(if (tuareg-smie--|-or-p) "|-or" "|"))
;; Some infix operators get a precedence based on their prefix, so we
;; collapse them into a canonical representative.
;; See https://v2.ocaml.org/manual/expr.html.
((memq (aref tok 0) '(?* ?/ ?% ?+ ?- ?@ ?^ ?= ?< ?> ?| ?& ?$))
(cond
((member tok '("|" "||" "&" "&&" "<-" "->" ">.")) tok)
((and (eq (aref tok 0) ?*) (> (length tok) 1) (eq (aref tok 1) ?*))
"**…")
(t (string (aref tok 0) ?…))))
((equal tok ":")
(let ((pos (point)))
(if (tuareg-smie--label-colon-p)
"label:"
(goto-char pos)
tok)))
((equal tok "exception")
(let ((back-tok (save-excursion (tuareg-smie--backward-token))))
(cond
((member back-tok '("|" "with")) "exception-case")
((equal back-tok "let") "exception-let")
(t tok))))
((string-match-p "\\`[[:alpha:]_].*\\.\\'" tok)
(forward-char (1- (length tok))) ".")
(t tok))))
(defun tuareg-smie-rules (kind token)
;; FIXME: Handling of "= |", "with |", "function |", and "[ |" is
;; problematic.
;; FIXME: Start with (pcase (cons kind token) ...) so Edebug jumps
;; straight to the appropriate branch!
(cond
;; Special indentation for module fields.
((and (eq kind :after) (member token '("." ";"))
(smie-rule-parent-p "with")
(tuareg-smie--with-module-fields-rule)))
((and (eq kind :after) (equal token ";;"))
0)
;; Special indentation for monadic >>>, >>|, >>=, and >|= operators.
((and (eq kind :before) (tuareg-smie--monadic-rule token)))
((and (equal token "and") (smie-rule-parent-p "type"))
0)
((member token '(";" "|" "," "and" "m-and"))
(cond
((and (eq kind :before) (member token '("|" ";"))
(smie-rule-parent-p "then")
;; We have misparsed the code: TOKEN is not a child of `then' but
;; should have closed the "if E1 then E2" instead!
(tuareg-smie--if-then-hack token)))
;; FIXME: smie-rule-separator doesn't behave correctly when the separator
;; is right after the parent (on another line).
((and (smie-rule-bolp) (smie-rule-prev-p "d=" "with" "[" "function"))
(if (and (eq kind :before) (smie-rule-bolp)
(smie-rule-prev-p "[" "d=" "function"))
0 tuareg-with-indent))
((and (equal token "|") (smie-rule-bolp) (not (smie-rule-prev-p "d="))
(smie-rule-parent-p "d="))
;; FIXME: Need a comment explaining what this tries to do.
;; FIXME: Should this only apply when (eq kind :before)?
;; FIXME: Don't use smie--parent.
(when (bound-and-true-p smie--parent)
(goto-char (cadr smie--parent))
(smie-indent-forward-token)
(tuareg-skip-blank-and-comments)
`(column . ,(- (current-column) 2))))
(t (smie-rule-separator kind))))
(t
(pcase kind
(`:elem (cond
((eq token 'basic) tuareg-default-indent)
;; The default tends to indent much too deep.
((eq token 'empty-line-token) ";;")))
(`:list-intro (member token '("fun")))
(`:close-all t)
(`:before
(cond
((equal token "d=") (smie-rule-parent 2))
((member token '("fun" "match"))
(and (not (smie-rule-bolp))
(cond ((smie-rule-prev-p "d=")
(smie-rule-parent tuareg-default-indent))
((smie-rule-prev-p "begin") (smie-rule-parent)))))
((equal token "then") (smie-rule-parent))
((equal token "if") (if (and (not (smie-rule-bolp))
(smie-rule-prev-p "else"))
(smie-rule-parent)))
((and (equal token "with") (smie-rule-parent-p "{"))
(smie-rule-parent))
((and (equal token "with") (smie-rule-parent-p "d="))
(let ((td (smie-backward-sexp "with")))
(cl-assert (equal (nth 2 td) "d="))
(goto-char (nth 1 td))
(setq td (smie-backward-sexp "d="))
;; Presumably (equal (nth 1 td) "type").
(goto-char (nth 1 td))
`(column . ,(smie-indent-virtual))))
;; Align the "with" of "module type A = B \n with ..." w.r.t "module".
((and (equal token "m-with") (smie-rule-parent-p "d="))
(save-excursion
(smie-backward-sexp token)
(goto-char (nth 1 (smie-backward-sexp 'halfsexp)))
(cons 'column (+ 2 (current-column)))))
;; Treat purely syntactic block-constructs as being part of their
;; parent, when the opening statement is hanging.
((member token '("let" "(" "[" "{" "sig" "struct" "begin"))
(when (and (smie-rule-hanging-p)
(apply #'smie-rule-prev-p
tuareg-smie--exp-operator-leader))
(if (let ((openers '("{" "(" "{<" "[" "[|")))
(or (apply #'smie-rule-prev-p openers)
(not (apply #'smie-rule-parent-p openers))))
(let ((offset (if (and (member token '("(" "struct" "sig"))
(not (smie-rule-parent-p "let" "d-let")))
0
tuareg-default-indent)))
(smie-rule-parent offset))
;; In "{ a = (", "{" and "a =" are not part of the same
;; syntax rule, so "(" is part of "a =" but not of the
;; surrounding "{".
(save-excursion
(smie-backward-sexp 'halfsexp)
(cons 'column (smie-indent-virtual))))))
((and tuareg-match-patterns-aligned
(equal token "|-or") (smie-rule-parent-p "|"))
(smie-rule-parent))
;; If we're looking at the first class-field-spec
;; in a "object(type)...end", don't rely on the default behavior which
;; will treat (type) as a previous element with which to align.
((tuareg-smie--object-hanging-rule token))
;; Apparently, people like their `| pattern when test -> body' to have
;; the `when' indented deeper than the body.
((equal token "when") (smie-rule-parent tuareg-match-when-indent))))
(`:after
(cond
((equal token "d=")
(and (smie-rule-parent-p "type")
(not (smie-rule-next-p "["))
0))
((equal token "->")
(cond
((smie-rule-parent-p "with")
;; Align with "with" but only if it's the only branch (often
;; the case in try..with), since otherwise subsequent
;; branches can't be both indented well and aligned.
(if (save-excursion
(and (not (equal "|" (nth 2 (smie-forward-sexp "|"))))
;; Since we may misparse "if..then.." we need to
;; double check that smie-forward-sexp indeed got us
;; to the right place.
(equal (nth 2 (smie-backward-sexp "|")) "with")))
(smie-rule-parent 2)
;; Align with other clauses, even with no preceding "|"
tuareg-match-clause-indent))
((smie-rule-parent-p "function")
;; Similar to the previous rule but for "function"
(if (save-excursion
(and (not (equal "|" (nth 2 (smie-forward-sexp "|"))))
(equal (nth 2 (smie-backward-sexp "|")) "function")))
(smie-rule-parent tuareg-default-indent)
tuareg-match-clause-indent))
((smie-rule-parent-p "|") tuareg-match-clause-indent)
;; Special case for "CPS style" code.
;; https://github.com/ocaml/tuareg/issues/5.
((smie-rule-parent-p "fun")
(save-excursion
(smie-backward-sexp "->")
(if (eq ?\( (char-before))
(cons 'column
(+ tuareg-default-indent
(progn
(backward-char 1)
(smie-indent-virtual))))
0)))
(t 0)))
((equal token ":")
(cond
((smie-rule-parent-p "val" "external") (smie-rule-parent 2))
((smie-rule-parent-p "module") (smie-rule-parent))
(t 2)))
((equal token "in") tuareg-in-indent) ;;(if (smie-rule-hanging-p)
((equal token "with")
(cond
;; ((smie-rule-next-p "|") 2)
((smie-rule-parent-p "{") nil)
(t (+ 2 tuareg-with-indent))))
((or (member token '("." "t->" "]"))
(consp (nth 2 (assoc token tuareg-smie-grammar)))) ;; Closer.
nil)
((member token '("{" "("))
;; The virtual indent after ( can be higher than the actual one
;; because it might be "column + tuareg-default-indent", whereas
;; the token only occupies a single column. So make sure we don't
;; get caught in this trap.
(let ((vi (smie-indent-virtual)))
(forward-char 1) ;Skip paren.
(skip-chars-forward " \t")
(unless (eolp)
`(column
. ,(min (current-column)
(+ tuareg-default-indent vi))))))
(t tuareg-default-indent)))))))
(defun tuareg-smie--with-module-fields-rule ()
;; Indentation of fields after "{ E with Module." where the "Module."
;; syntactically only applies to the first field, but has
;; semantically a higher position since it applies to all fields.
(save-excursion
(forward-char 1)
(smie-backward-sexp 'halfsexp)
(when (looking-at "\\(?:\\sw\\|\\s_\\)+\\.[ \t]*$")
(smie-backward-sexp 'halfsexp)
(cons 'column (current-column)))))
(defconst tuareg-smie--monadic-operators '(">>|" ">>=" ">>>" ">|=")
"Monadic infix operators")
(defconst tuareg-smie--monadic-op-re
(regexp-opt tuareg-smie--monadic-operators))
(defun tuareg-smie--monadic-rule (token)
;; When trying to indent a >>=, try to look back to find any earlier
;; >>= in a sequence of "monadic steps".
(or (and (equal token ">…") (looking-at tuareg-smie--monadic-op-re)
(save-excursion
(tuareg-smie--forward-token)
(let ((indent nil))
(while
(let ((parent-data (smie-backward-sexp 'halfsexp)))
(cond
((car parent-data) (member (nth 2 parent-data) '("->")))
((member (nth 2 parent-data) '(";" "d=")) nil)
((member (nth 2 parent-data) '("fun" "function"))
(if (member (tuareg-smie--backward-token)
tuareg-smie--monadic-operators)
(progn
(setq indent (cons 'column
(smie-indent-virtual)))
nil)
t)))))
indent)))
;; In "foo >>= fun x -> bar" indent `bar' relative to `foo'.
(and (member token '("fun" "function")) (not (smie-rule-bolp))
(save-excursion
(let ((prev (tuareg-smie-backward-token)))
;; FIXME: Should we use the same loop as above?
(and (equal prev ">…") (looking-at tuareg-smie--monadic-op-re)
(progn (smie-backward-sexp prev)
(cons 'column (current-column)))))))))
(defun tuareg-smie--object-hanging-rule (token)
;; If we're looking at the first class-field-spec
;; in a "object(type)...end", don't rely on the default behavior which
;; will treat (type) as a previous element with which to align.
(cond
;; An important role of this first condition is to call smie-indent-virtual
;; so that we get called back to compute the (virtual) indentation of
;; "object", thus making sure we get called back to apply the second rule.
((and (member token '("inherit" "val" "method" "constraint" "initializer"))
(smie-rule-parent-p "object"))
(save-excursion
(forward-word 1)
(goto-char (nth 1 (smie-backward-sexp 'halfsexp)))
(let ((col (smie-indent-virtual)))
`(column . ,(+ tuareg-default-indent col)))))
;; For "class foo = object(type)...end", align object...end with class.
((and (equal token "object") (smie-rule-parent-p "class")
(not (smie-rule-bolp)))
(smie-rule-parent))))
(defun tuareg-smie--if-then-hack (token)
;; Getting SMIE's parser to properly parse "if E1 then E2" is difficult, so
;; instead we live with a confused parser and try to work around the mess
;; here, although it clearly won't help other uses of the parser
;; (e.g. navigation).
(save-excursion
(let (pd)
(while (equal (nth 2 (setq pd (smie-backward-sexp token))) "then")
(let ((pdi (smie-backward-sexp 'halfsexp)))
(cl-assert (equal (nth 2 pdi) "if"))))
(cond
((equal (nth 2 pd) token)
(goto-char (nth 1 pd))
(cons 'column (smie-indent-virtual)))
((and (equal token "|") (equal (nth 2 pd) "with")
(not (smie-rule-bolp)))
(goto-char (nth 1 pd))
(cons 'column (+ 3 (current-column))))
(t (cons 'column (current-column)))))))
(defun tuareg-smie--inside-string ()
(when (nth 3 (syntax-ppss))
(save-excursion
(goto-char (1+ (nth 8 (syntax-ppss))))
(current-column))))
(defcustom tuareg-indent-align-with-first-arg nil
"Non-nil if indentation should try to align arguments on the first one.
With a non-nil value you get
let x = List.map (fun x -> 5)
my list
whereas with a nil value you get
let x = List.map (fun x -> 5)
my list"
:type 'boolean)
(defun tuareg-smie--args ()
;; FIXME: This is largely copy&pasted from smie.el. SMIE should offer a way
;; to hook into smie-indent-exps in order to control that behavior.
(unless (or tuareg-indent-align-with-first-arg
(nth 8 (syntax-ppss))
(looking-at comment-start-skip)
(looking-at "[ \t]*$") ;; bug#179
(numberp (nth 1 (save-excursion (smie-indent-forward-token))))
(numberp (nth 2 (save-excursion (smie-indent-backward-token)))))
(save-excursion
(let ((positions nil)
arg)
(while (and (null (car (smie-backward-sexp)))
(push (point) positions)
(not (smie-indent--bolp))))
(save-excursion
;; Figure out if the atom we just skipped is an argument rather
;; than a function.
(setq arg
(or (null (car (smie-backward-sexp)))
(funcall smie-rules-function :list-intro
(funcall smie-backward-token-function)))))
(cond
((null positions)
;; We're the first expression of the list. In that case, the
;; indentation should be (have been) determined by its context.
nil)
(arg
;; There's a previous element, and it's not special (it's not
;; the function), so let's just align with that one.
(goto-char (car positions))
(if (fboundp 'smie-indent--current-column)
(smie-indent--current-column)
(current-column)))
(t
;; There's no previous arg at BOL. Align with the function.
(goto-char (car positions))
(+ (smie-indent--offset 'args)
;; We used to use (smie-indent-virtual), but that
;; doesn't seem right since it might then indent args less than
;; the function itself.
(if (fboundp 'smie-indent--current-column)
(smie-indent--current-column)
(current-column)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Phrase movements and indentation
(defun tuareg--skip-backward-comment ()
"Skip backward a single comment and at most one preceding newline.
Return a non-nil value if a comment was skipped."
;; We do not want to skip newlines after the comment (as
;; `forward-comment'), so we skip spaces by hand and check we are at
;; the end of a comment.
(skip-chars-backward " \t")
(let ((opoint (point)))
(if (and (char-equal (preceding-char) ?\)) (forward-comment -1))
(progn
(skip-chars-backward " \t")
(skip-chars-backward "\n" (1- (point)))
t)
(goto-char opoint)
nil)))
(defun tuareg--skip-backward-comments-semicolon ()
"Skip `sticky' comments and `;;' after a definition."
;; Comments after the definition not separated by a blank like
;; ("sticking") are considered part of the definition.
(when (looking-at-p "[ \t]*(\\*")
(skip-chars-backward " \t")
(skip-chars-backward "\n" (1- (point))))
(while (tuareg--skip-backward-comment))
(skip-chars-backward " \t;"))
(defun tuareg--skip-forward-comment ()
"Skip forward a single comment and at most one subsequent newline.
Return a non-nil value if a comment was skipped."
(skip-chars-forward " \t")
(let ((opoint (point)))
(skip-chars-forward "\n" (1+ (point)))
(skip-chars-forward " \t")
(if (and (char-equal (following-char) ?\() (forward-comment 1))
t
(goto-char opoint)
nil)))
(defun tuareg--skip-forward-comments-semicolon ()
"Skip `;;' and then `sticky' comments after a definition."
(when (looking-at (rx (* (in " \t\n")) ";;"))
(goto-char (match-end 0)))
(while (tuareg--skip-forward-comment)))
(defvar-local tuareg-smie--forward-and-cache nil
"Alist memoising results from (smie-forward-sexp \"and\").")
(defvar-local tuareg-smie--backward-and-cache nil
"Alist memoising results from (smie-backward-sexp \"and\").
Each element is (POS-BEFORE POS-AFTER VALUE) where POS-BEFORE and
POS-AFTER are the positions before and after the call
respectivaly, and VALUE what the call returned.")
(defvar-local tuareg-smie--and-cache-tick nil
"Buffer-modification tick at which and-caches are valid.
Applies to `tuareg-smie--forward-and-cache'
and `tuareg-smie--backward-and-cache'.")
(defun tuareg-backward-beginning-of-defun (&optional stay-in-current)
"Move the point backward to the beginning of a definition.
Return the token starting the phrase (`nil' if it is an expression).
If STAY-IN-CURRENT is non-nil, don't go to the previous defun if already
at the start of one."
(let ((state (syntax-ppss)))
(cond
;; In a string: move to its end (via the beginning).
((nth 3 state)
(goto-char (nth 8 state))
(smie-forward-sexp))
;; In a comment: move to its beginning.
((nth 4 state)
(goto-char (nth 8 state)))
;; At start of a word and we may move to previous defun: stay put.
((and (not stay-in-current)
(looking-at (rx symbol-start))))
;; If in or at the beginning of a word, move to the end.
((/= (skip-syntax-forward "w_") 0))
;; Otherwise, skip possibly trailing ";;".
(t (tuareg--skip-backward-comments-semicolon))))
;; We treat each "and" clause belonging to "d-let" or "type" as defuns
;; in the own right since that is how programmers think about it.
(let* ((opoint (point))
(and-pos nil)
(ret-tok nil)
(tick (buffer-chars-modified-tick))
(cache-valid (eql tuareg-smie--and-cache-tick tick)))
(while
(and (not (bobp))
;; Memoised call to (smie-backward-sexp "and")
(let* ((cached
(and cache-valid
(assq (point) tuareg-smie--backward-and-cache)))
(td (if cached
(progn
(goto-char (nth 1 cached))
(nth 2 cached))
(unless cache-valid
(setq tuareg-smie--forward-and-cache nil)
(setq tuareg-smie--backward-and-cache nil)
(setq tuareg-smie--and-cache-tick tick)
(setq cache-valid t))
(let* ((pt (point))
(r (smie-backward-sexp "and")))
(push (list pt (point) r)
tuareg-smie--backward-and-cache)
r))))
(and (nth 0 td)
(let ((tpos (nth 1 td))
(tok (nth 2 td)))
(cond
;; Arrived at a token that always starts a defun.
((member tok '("type" "d-let" "exception" "module"
"class" "val" "external" "open"))
(if (and and-pos (member tok '("d-let" "type")))
;; Previously found "and" is the start of the
;; defun: return it.
(progn
(goto-char and-pos)
(setq ret-tok "and"))
;; This is the start of the defun.
(goto-char tpos)
(setq ret-tok tok))
nil)
;; Arrived at "and": keep going backwards to find
;; out whether it was the start of a defun.
((equal tok "and")
(unless and-pos
(setq and-pos tpos))
(goto-char tpos)
t)
;; Arrived at "let": keep going backwards.
((equal tok "let")
;; Any previous "and" was not the start of a defun.
(setq and-pos nil)
(goto-char tpos)
t)
((equal tok ";;")
(if (and (= (point) opoint) (not stay-in-current))
;; Assume this ";;" to be the last part of
;; the defun to go past: skip and continue.
(progn
(goto-char tpos)
t)
;; This marks the beginning of the defun.
(setq ret-tok t) ; Any non-nil value should do.
nil))
((member tok '("do" "downto" "to"))
(goto-char tpos)
t)
;; Left bracket or similar: keep going.
((not (numberp (nth 0 td)))
(goto-char tpos)
t)
;; Something else: stop.
(t nil)))))))
ret-tok))
(defun tuareg-smie--forward-sexp-and ()
"Memoised (smie-forward-sexp \"and\"), point motion only."
(let* ((tick (buffer-chars-modified-tick))
(cache-valid (eql tuareg-smie--and-cache-tick tick))
(cached (and cache-valid
(assq (point) tuareg-smie--forward-and-cache))))
(if cached
(goto-char (cdr cached))
(unless cache-valid
(setq tuareg-smie--forward-and-cache nil)
(setq tuareg-smie--backward-and-cache nil)
(setq tuareg-smie--and-cache-tick tick))
(let ((pt (point)))
(smie-forward-sexp "and")
(push (cons pt (point)) tuareg-smie--forward-and-cache)))))
(defun tuareg-end-of-defun ()
"Assuming that we are at the beginning of a definition, move to its end.
See variable `end-of-defun-function'."
(interactive)
(let* ((start (point))
(head (tuareg-smie--forward-token))) ; Skip the head token.
(cond
((member head '("type" "d-let" "let" "and" "exception" "module"
"class" "val" "external" "open"))
;; Non-expression defun.
(tuareg-smie--forward-sexp-and)
(let ((end (point)))
;; Check whether this defun is part of a let...and... chain that
;; ends with "in", in which case it is a single big defun.
;; Otherwise, go back to the first end position.
(while
(let ((tok (tuareg-smie--forward-token)))
(cond ((equal tok "and")
;; Skip the "and" clause and keep looking.
(tuareg-smie--forward-sexp-and)
t)
((equal tok "in")
;; It's an expression, not a declaration: go to its end.
(tuareg-smie--forward-sexp-and)
nil)
(t
;; No "in" found; use what we had at the start.
(goto-char end)
nil))))))
(t
;; Expression: go back and skip it all at once.
(goto-char start)
(smie-forward-sexp ";;"))))
(tuareg--skip-forward-comments-semicolon))
(defun tuareg-beginning-of-defun (&optional arg)
"Move point backward to the beginning of a definition.
See variable `beginning-of-defun-function'."
(interactive "^P")
(unless arg (setq arg 1))
(let ((ret t))
(cond
((>= arg 0)
(while (and (> arg 0) ret)
(unless (tuareg-backward-beginning-of-defun)
(setq ret nil))
(cl-decf arg)))
(t
(while (and (< arg 0) ret)
(let ((start (point)))
(tuareg-end-of-defun)
(skip-chars-forward " \t\n")
(tuareg--skip-forward-comments-semicolon)
(let ((end (point)))
(tuareg-backward-beginning-of-defun)
;; Did we make forward progress?
(when (<= (point) start)
;; No, try again.
(goto-char end)
(tuareg-end-of-defun)
(skip-chars-forward " \t\n")
(tuareg--skip-forward-comments-semicolon)
(tuareg-backward-beginning-of-defun)
;; This time?
(when (<= (point) start)
;; No, no more defuns.
(goto-char (point-max))
(setq ret nil)))))
(cl-incf arg))))
ret))
(defun tuareg-skip-siblings ()
(while (and (not (bobp))
(let ((td (smie-backward-sexp)))
(or (null (car td))
(and (string= (nth 2 td) ";;")
(tuareg-smie-backward-token)))))
(tuareg-backward-beginning-of-defun t)
(forward-comment (- (point))))
(when (looking-at-p "in")
;; Skip over `local...in' and continue.
(forward-word 1)
(smie-backward-sexp 'halfsexp)
(tuareg-skip-siblings)))
(defun tuareg--current-fun-name ()
(when (tuareg-backward-beginning-of-defun t)
(save-excursion (tuareg-smie-forward-token)
(tuareg-skip-blank-and-comments)
(let ((name (tuareg-smie-forward-token)))
(if (not (member name '("rec" "type")))
name
(tuareg-skip-blank-and-comments)
(tuareg-smie-forward-token))))))
(defcustom tuareg-max-name-components 3
"Maximum number of components to use for the current function name."
:type 'integer)
(defun tuareg-current-fun-name ()
(save-excursion
(let ((count tuareg-max-name-components)
fullname name)
(end-of-line)
(while (and (> count 0)
(setq name (tuareg--current-fun-name)))
(cl-decf count)
(setq fullname (if fullname (concat name "." fullname) name))
;; Skip all other declarations that we find at the same level.
(tuareg-skip-siblings))
fullname)))
(define-obsolete-function-alias 'tuareg--beginning-of-phrase
#'tuareg-backward-beginning-of-defun
"Apr 10, 2019")
(defun tuareg-region-of-defun (&optional pos)
"Return a couple (BEGIN . END) for the OCaml phrase around POS,
including comments after the phrase. In case of error, move the
point at the beginning of the error and return `nil'."
(let ((complete-phrase t)
begin end)
(save-excursion
(if pos (goto-char pos))
;; If the beginning of the defun was an "and", try again until we
;; get to the start of the phrase.
(while (equal (tuareg-backward-beginning-of-defun t) "and")
(forward-char -1))
(setq begin (point))
;; Go all the way to the end of the phrase (not just the defun,
;; which could end at an "and").
(let ((head (tuareg-smie-forward-token)))
(unless (member head '("type" "d-let" "let" "and" "exception" "module"
"class" "val" "external" "open"))
;; Expression phrase.
(goto-char begin)))
(smie-forward-sexp ";;")
(tuareg--skip-forward-comments-semicolon)
(setq end (point))
;; Check if we were not stuck (after POS) because the phrase was
;; not well parenthesized.
(when (and complete-phrase (< (point) (point-max)))
(smie-forward-sexp 'halfsexp)
(when (= end (point)); did not move
(setq complete-phrase nil))))
(if complete-phrase
(cons begin end)
(goto-char end)
nil)))
(defun tuareg-discover-phrase (&optional pos)
"Return a triplet (BEGIN END END-WITH-COMMENTS) for the OCaml
phrase around POS. In case of error, move the point at the
beginning of the error and return `nil'."
(let ((r (tuareg-region-of-defun pos))
end-without-comments)
(when r
;; Remove possible comments after the phrase.
(goto-char (cdr r))
(forward-comment (- (point)))
(setq end-without-comments (point))
(list (car r) end-without-comments (cdr r)))))
(defun tuareg--string-boundaries ()
"Assume point is inside a string and return (START . END), the
positions delimiting the string (including its delimiters)."
(save-excursion
(let ((start (nth 8 (syntax-ppss)))
end)
(goto-char start)
(smie-forward-sexp)
(setq end (1- (point)))
(cons start end))))
(defun tuareg--fill-string ()
"Assume the point is inside a string delimited by \" and jusfify it.
This function moves the point."
;; FIXME: be more subtle: detect lists and @param
(let* ((start-end (tuareg--string-boundaries))
(start (set-marker (make-marker) (car start-end)))
(end (set-marker (make-marker) (cdr start-end)))
fill-prefix
(fill-individual-varying-indent t)
(use-hard-newlines t))
(indent-region (marker-position start) (marker-position end))
;; Delete all backslash protected newlines except those without
;; a preceding space that serve to cut a long word.
(goto-char (marker-position start))
;;(indent-according-to-mode)
(setq fill-prefix (make-string (1+ (current-column)) ?\ ))
(if (looking-at "\"\\\\ *[\n\r] *")
(replace-match "\""))
(while (re-search-forward " +\\\\ *[\n\r] *" (marker-position end) t)
(replace-match " "))
(set-hard-newline-properties (marker-position start)
(marker-position end))
;; Do not include the final \" not to remove space before it:
(fill-region (marker-position start) (1- (marker-position end)))
;; Protect all soft newlines
(goto-char (marker-position start))
(end-of-line)
(while (< (point) (marker-position end))
(unless (get-char-property (point) 'hard)
(insert " \\"))
(forward-char)
(end-of-line))
(set-marker start nil)
(set-marker end nil)))
(defun tuareg--fill-comment ()
"Assumes the point is inside a comment and justify it.
This function moves the point."
(let* ((com-start (nth 8 (syntax-ppss)))
content-start
com-end
in-doc-comment
par-start
par-end)
(save-excursion
(goto-char com-start)
(setq content-start (and (looking-at comment-start-skip)
(match-end 0)))
(setq in-doc-comment (looking-at-p (rx "(**" (not (in "*")))))
(forward-comment 1)
(setq com-end (point)))
;; In doc comments, let @tags start a paragraph.
(let ((paragraph-start
(if in-doc-comment
(concat paragraph-start
"\\|"
(rx (* (in " \t")) "@" (+ (in "a-z")) symbol-end))
paragraph-start)))
(save-restriction
(narrow-to-region content-start com-end)
(save-excursion
(skip-chars-forward " \t")
(backward-paragraph)
(skip-chars-forward " \t\n")
(setq par-start (point))
(forward-paragraph)
(setq par-end (point))))
;; Set `fill-prefix' to preserve the indentation of the start of the
;; paragraph, assuming that is what the user wants.
(let ((fill-prefix
(save-excursion
(goto-char par-start)
(let ((col
(if (and in-doc-comment
(looking-at-p
(rx "@" (+ (in "a-z")) symbol-end)))
;; Indent two spaces under @tag.
(+ 2 (current-column))
(current-column))))
(make-string col ?\s)))))
(fill-region-as-paragraph par-start par-end)))))
(defun tuareg-indent-phrase ()
"Depending of the context: justify and indent a comment,
or indent all lines in the current phrase."
(interactive)
(save-excursion
(let ((ppss (syntax-ppss)))
(cond
((equal ?\" (nth 3 ppss))
(tuareg--fill-string))
((nth 4 ppss)
(tuareg--fill-comment))
(t (let ((phrase (tuareg-region-of-defun)))
(if phrase
(indent-region (car phrase) (cdr phrase)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Commenting
(defun tuareg--end-of-string-or-comment (state)
"Return the end position of the comment or string given by STATE."
(save-excursion
(goto-char (nth 8 state))
(if (nth 4 state) (comment-forward 1) (forward-sexp))
(point)))
(defun tuareg-comment-or-uncomment-region (beg end &optional arg)
"Replacement for `comment-or-uncomment-region' tailored for OCaml."
(interactive "*r\nP")
(comment-normalize-vars)
(setq beg (save-excursion (goto-char beg)
(skip-chars-forward " \t\r\n")
(point)))
(setq end (save-excursion (goto-char end)
(skip-chars-backward " \t\r\n")
(point)))
(let (state pos)
;; Include the comment or string to which BEG possibly belongs
(setq pos (nth 8 (syntax-ppss beg)))
(if pos (setq beg pos))
;; Include the comment or string to which END possibly belongs
(setq state (syntax-ppss end))
(if (nth 8 state)
(setq end (tuareg--end-of-string-or-comment state)))
(if (comment-only-p beg end)
(uncomment-region beg end arg)
(comment-region beg end arg))))
(defun tuareg-comment-dwim (&optional arg)
"Replacement for `comment-dwim' tailored for OCaml."
(interactive "*P")
(comment-normalize-vars)
(if (use-region-p)
(save-excursion
(tuareg-comment-or-uncomment-region (region-beginning)
(region-end) arg))
(let ((state (syntax-ppss)))
(cond
((nth 4 state)
;; Point inside a comment. Uncomment just as if a region
;; inside the comment was active.
(uncomment-region (nth 8 state)
(tuareg--end-of-string-or-comment state) arg))
((nth 3 state); Point inside a string.
(comment-region (nth 8 state)
(tuareg--end-of-string-or-comment state) arg))
((looking-at-p "[ \t]*$"); at end of line and not in string
(comment-dwim arg))
(t (save-excursion
(tuareg-comment-or-uncomment-region (line-beginning-position)
(line-end-position) arg)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; The major mode
(defalias 'tuareg-find-alternate-file #'ff-get-other-file)
(defvar merlin-enclosing-types); Silence the byte-compiler.
(defvar merlin-enclosing-offset)
(declare-function merlin--type-enclosing-query "merlin" ())
(declare-function merlin--type-enclosing-text "merlin" (item))
(defun tuareg--merlin-buffer-signature (buf)
"Return the signature of BUF or nil if there was a problem."
(let (sig)
(with-temp-buffer
(insert "module TuaregBufferSignature = struct\n")
(insert-buffer-substring-no-properties buf)
(insert "\nend")
(goto-char (point-min))
(when (merlin--type-enclosing-query)
;; Similar to `merlin--type-enclosing-go' but return the type.
(let ((data (elt merlin-enclosing-types merlin-enclosing-offset)))
(if (cddr data)
(setq sig (merlin--type-enclosing-text data))))))
(when (and sig (string-match "\\`sig\\>" sig) (>= (length sig) 9))
(setq sig (string-trim (substring sig 3 -3)))
(replace-regexp-in-string "\n " "\n" sig))))
(defun tuareg--ff-file-created-hook ()
(when (and (string-match "\\.mli\\'" (buffer-file-name))
(y-or-n-p "Try to generate interface?"))
(if (require 'merlin nil t)
(let* (ml-buf ty)
(ff-find-the-other-file);; back to .ml
;; FIXME: special action for .pp.ml files?
(setq ml-buf (current-buffer))
(ff-find-the-other-file)
(setq ty (tuareg--merlin-buffer-signature ml-buf))
(when ty
(insert ty)))
(message "Install the OPAM package \"merlin\" and follow the Emacs instructions."))))
(defun tuareg--switch-outside-build ()
"If the current buffer refers to a file under a _build
directory and a corresponding file exists outside the _build
directory, propose the user to switch to it. Return t if the
switch was made."
(let ((fpath (buffer-file-name))
(p nil)
(in-build nil)
base b)
(when fpath
;; Inspired by `locate-dominating-file'.
(setq fpath (abbreviate-file-name fpath))
(setq base (file-name-nondirectory fpath))
(setq fpath (file-name-directory fpath))
(while (not (or in-build
(null fpath)
(string-match-p locate-dominating-stop-dir-regexp fpath)))
(setq b (file-name-nondirectory (directory-file-name fpath)))
(if (string= b "_build")
(setq in-build t)
(push (file-name-as-directory b) p)
(if (equal fpath (setq fpath (file-name-directory
(directory-file-name fpath))))
(setq fpath nil))))
(when in-build
;; Make `fpath' the path without _build.
(setq fpath (file-name-directory (directory-file-name fpath)))
;; jbuilder prefixes the path with a dir, not ocamlbuild
(let* ((context (pop p))
(rel-fpath (concat (apply #'concat p) base))
(alt0 (concat fpath rel-fpath)); jbuilder
(alt1 (concat fpath context rel-fpath)); ocamlbuild
(alt (if (file-readable-p alt0) alt0))
(alt (or alt (if (file-readable-p alt1) alt1))))
(if (and alt
(y-or-n-p "File in _build. Switch to corresponding \
file outside _build? "))
(progn
(kill-buffer)
(find-file alt)
t)
(read-only-mode)
(message "File in _build. C-x C-q to edit.")
nil))))))
(defun tuareg--hanging-eolp-advice ()
"Recognize \"fun ..args.. ->\" at EOL as being hanging."
(when (looking-at "fun\\_>")
(smie-indent-forward-token)
;; We define a special "-dlpd-" token
;; ("-dummy-left-pattern-delimiter-") in the grammar
;; specifically so as to be able to make the right
;; call to smie-forward-sexp here.
(if (equal "->" (nth 2 (smie-forward-sexp "-dlpd-")))
(smie-indent-forward-token))))
(defun tuareg--blink-matching-check (orig-fun &rest args)
(if (tuareg--point-after-comment-p)
;; Immediately after a comment-ending "*)" -- no mismatch error.
nil
(apply orig-fun args)))
(defvar show-paren-data-function); Silence the byte-compiler
(defun tuareg--show-paren (orig-fun)
"Advice for `show-paren-data-function' to match comment delimiters."
(cond
;; Immediately after "*)"
((and (eq (char-before) ?\))
(eq (char-before (1- (point))) ?*))
(let* ((here-beg (- (point) 2))
(ppss (save-excursion (syntax-ppss here-beg)))
(comment-nesting (nth 4 ppss)))
(cond
(comment-nesting ; "*)" ends a comment
(let* ((there-beg (if (= comment-nesting 1) (nth 8 ppss)
(save-excursion (forward-comment -1)
(point))))
(ofs (if (eq (char-after (+ there-beg 2)) ?*) 3 2)))
(list here-beg (point) there-beg (+ there-beg ofs) nil)))
((nth 3 ppss); inside a string, don't consider "*)" as a closer
nil)
;; Mismatch
(t (list here-beg (point) here-beg (point) t)))))
;; Immediately before "(*"
((and (eq (char-after) ?\()
(eq (char-after (1+ (point))) ?*))
(save-excursion
(let* ((here-beg (point))
(ofs (if (eq (char-after (+ here-beg 2)) ?*) 3 2))
(here-end (+ here-beg ofs))
(ppss (syntax-ppss here-end)))
(cond
((nth 4 ppss); "(*" starts a comment
(if (progn (goto-char here-beg)
(forward-comment 1))
(list here-beg here-end (- (point) 2) (point) nil)
(list here-beg here-end here-beg here-end t)))
((nth 3 ppss); inside a string, don't consider "(*" as an opener
nil)
;; Mismatch
(t (list here-beg here-end here-beg here-end t))))))
(t (funcall orig-fun))))
(defun tuareg--indent-line-inside-comment ()
"Indent the current line if it is inside a comment."
(let ((ppss (syntax-ppss)))
(and (nth 4 ppss)
(let ((indent-col
(save-excursion
(let* ((com-start (nth 8 ppss))
(in-doc-comment
(save-excursion
(goto-char com-start)
(looking-at-p (rx "(**" (not (in "*"))))))
tag-starts-line)
;; Use the indentation of the previous nonempty line.
;; If we are in a doc comment and that line
;; starts with an @tag, and the current line
;; doesn't, then indent to after the @tag.
(goto-char (max com-start (line-beginning-position)))
(setq tag-starts-line
(and in-doc-comment
(looking-at-p
(rx (* (in " \t"))
"@" (+ (in "a-z")) symbol-end))))
(skip-chars-backward " \t\n" com-start)
(goto-char (max com-start (line-beginning-position)))
(when (looking-at (rx "(*" (* "*")))
(goto-char (match-end 0)))
(skip-chars-forward " \t")
(when (and in-doc-comment
(not tag-starts-line)
(looking-at-p (rx "@" (+ (in "a-z")) " ")))
(forward-char 2)))
(current-column))))
(indent-line-to indent-col)
t))))
(defun tuareg--indent-line (orig-fun)
(let ((res (funcall orig-fun)))
(if (eq res 'noindent)
(tuareg--indent-line-inside-comment)
res)))
(defun tuareg--common-mode-setup ()
(setq-local syntax-propertize-function #'tuareg-syntax-propertize)
(setq-local parse-sexp-ignore-comments t)
(smie-setup tuareg-smie-grammar #'tuareg-smie-rules
:forward-token #'tuareg-smie-forward-token
:backward-token #'tuareg-smie-backward-token)
(when (boundp 'smie--hanging-eolp-function)
;; FIXME: As its name implies, smie--hanging-eolp-function
;; is not to be used by packages like us, but SMIE's maintainer
;; hasn't provided any alternative so far :-(
(add-function :before (local 'smie--hanging-eolp-function)
#'tuareg--hanging-eolp-advice))
(add-function :around (local 'indent-line-function)
#'tuareg--indent-line)
(add-hook 'smie-indent-functions #'tuareg-smie--args nil t)
(add-hook 'smie-indent-functions #'tuareg-smie--inside-string nil t)
(setq-local add-log-current-defun-function #'tuareg-current-fun-name)
(add-function :around (local 'blink-matching-check-function)
#'tuareg--blink-matching-check)
(when tuareg-comment-show-paren
(add-function :around (local 'show-paren-data-function)
#'tuareg--show-paren))
(setq prettify-symbols-alist
(if tuareg-prettify-symbols-full
(append tuareg-prettify-symbols-basic-alist
tuareg-prettify-symbols-extra-alist)
tuareg-prettify-symbols-basic-alist))
(when (boundp 'prettify-symbols-compose-predicate) ; Emacs 25 or later
(setq prettify-symbols-compose-predicate
#'tuareg--prettify-symbols-compose-p))
(setq-local open-paren-in-column-0-is-defun-start nil)
(add-hook 'completion-at-point-functions #'tuareg-completion-at-point nil t)
(add-hook 'electric-indent-functions
#'tuareg--electric-indent-predicate nil t)
(add-hook 'post-self-insert-hook #'tuareg--electric-close-vector nil t))
;;;###autoload(add-to-list 'auto-mode-alist '("\\.ml[ip]?\\'" . tuareg-mode))
;;;###autoload(add-to-list 'auto-mode-alist '("\\.eliomi?\\'" . tuareg-mode))
;;;###autoload(dolist (ext '(".cmo" ".cmx" ".cma" ".cmxa" ".cmi"
;;;###autoload ".annot" ".cmt" ".cmti"))
;;;###autoload (add-to-list 'completion-ignored-extensions ext))
(defvar compilation-first-column)
(defvar compilation-error-screen-columns)
(defun tuareg--other-file (filename)
"Given a FILENAME \"foo.ml\", return \"foo.mli\" if it exists.
Return nil otherwise."
;; FIXME: Share code with `tuareg-find-alternate-file'.
(when filename
(catch 'found
(let* ((file-no-ext (file-name-sans-extension filename))
(matching-exts
(catch 'found
(pcase-dolist (`(,rx ,exts) tuareg-other-file-alist)
(when (string-match-p rx filename) (throw 'found exts))))))
(dolist (ext matching-exts)
(when (file-exists-p (concat file-no-ext ext))
(throw 'found (substring ext 1))))))))
(defvar-local tuareg--other-file nil)
(defvar tuareg-mode-name "Tuareg")
;;;###autoload
(define-derived-mode tuareg-mode prog-mode "Tuareg"
"Major mode for editing OCaml code.
Provides automatic indentation and compilation interface. Performs font/color
highlighting using Font-Lock. It is designed for OCaml but handles
Caml Light as well.
The Font-Lock minor-mode is used according to your customization
options.
You have better byte-compile tuareg.el.
For customization purposes, you should use `tuareg-mode-hook'
\(run for every file) or `tuareg-load-hook' (run once) and not patch
the mode itself. You should add to your configuration file something like:
(add-hook \\='tuareg-mode-hook
(lambda ()
... ; your customization code
))
For example you can change the indentation of some keywords, the
`electric' flags, Font-Lock colors... Every customizable variable is
documented, use `C-h-v' or look at the mode's source code.
`dot-emacs.el' is a sample customization file for standard changes.
You can append it to your `.emacs' or use it as a tutorial.
`M-x ocamldebug' FILE starts the OCaml debugger ocamldebug on the executable
FILE, with input and output in an Emacs buffer named *ocamldebug-FILE*.
A Tuareg Interactive Mode to evaluate expressions in a REPL (aka toplevel) is
included. Type `M-x tuareg-run-ocaml' or simply `M-x run-ocaml' or see
special-keys below.
Short cuts for the Tuareg mode:
\\{tuareg-mode-map}
Short cuts for interactions with the REPL:
\\{tuareg-interactive-mode-map}"
(setq mode-name
'(tuareg--other-file
;; FIXME: Clicking on the "+mli" should probably jump to the
;; .mli file.
("" tuareg-mode-name "[+" tuareg--other-file "]")
tuareg-mode-name))
;; FIXME: Update `tuareg--other-file' every once in a while, e.g. when we
;; save the `.ml' or `.mli' file.
(setq tuareg--other-file
(if tuareg-mode-line-other-file (tuareg--other-file buffer-file-name)))
(unless (tuareg--switch-outside-build)
;; Initialize the Tuareg menu
(tuareg-build-menu)
(setq-local paragraph-start (concat "^[ \t]*$\\|\\*)$\\|" page-delimiter))
(setq-local paragraph-separate paragraph-start)
(setq-local require-final-newline mode-require-final-newline)
(setq-local comment-start "(* ")
(setq-local comment-end " *)")
(setq-local comment-start-skip "(\\*+[ \t]*")
;; `ocamlc' counts columns from 0, contrary to other tools which start at 1.
(setq-local compilation-first-column 0)
(setq-local compilation-error-screen-columns nil)
;; TABs should NOT be used in OCaml files:
(setq indent-tabs-mode nil)
(setq ff-search-directories '(".")
ff-other-file-alist tuareg-other-file-alist)
(add-hook 'ff-file-created-hook #'tuareg--ff-file-created-hook nil t)
(tuareg--common-mode-setup)
(tuareg--install-font-lock)
(setq-local beginning-of-defun-function #'tuareg-beginning-of-defun)
(setq-local end-of-defun-function #'tuareg-end-of-defun)
(setq imenu-create-index-function #'tuareg-imenu-create-index)
(run-mode-hooks 'tuareg-load-hook)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Error processing
(require 'compile)
;; Autoload the addition of the compilation error matcher so that it works
;; even if the user hasn't visited any OCaml files or loaded Tuareg by other
;; means.
;;;###autoload
(with-eval-after-load 'compile
(let ((rule
(eval-when-compile
`(ocaml
,(rx
bol
;; Require either zero or 7 leading spaces, to avoid matching
;; Python tracebacks. Assume that spaces mean that this is an
;; ancillary location that should have level Info.
;; FIXME: Ancillary locations for warnings probably
;; have no spaces and are now treated as errors.
;; Fortunately these are rare.
(? (group-n 9 " ")) ; 9: INFO
(group-n 1 ; 1: HIGHLIGHT
(or "File "
;; Exception backtrace.
(seq
(or "Raised at" "Re-raised at"
"Raised by primitive operation at"
"Called from")
(* nonl) ; OCaml ≥4.11: " FUNCTION in"
" file "))
(group-n 2 (? "\"")) ; 2
(group-n 3 (+ (not (in "\t\n \",<>")))) ; 3: FILE
(backref 2)
(? " (inlined)")
", line" (? "s") " "
(group-n 4 (+ (in "0-9"))) ; 4: LINE-START
(? "-" (group-n 5 (+ (in "0-9")))) ; 5; LINE-END
(? ", character" (? "s") " "
(group-n 6 (+ (in "0-9"))) ; 6: COL-START
(? "-" (group-n 7 (+ (in "0-9"))))) ; 7: COL-END
;; Colon not present in backtraces.
(? ":"))
(? "\n"
(* (in "\t "))
(* (or (seq (+ (in "0-9"))
" | "
(* nonl))
(+ "^"))
"\n"
(* (in "\t ")))
(group-n 8 (or "Warning" "Alert") ; 8: WARNING
(* (not (in ":\n")))
":")))
3 (4 . 5) (6 . tuareg--end-column) (8 . 9) 1
(8 font-lock-function-name-face)))))
(defvar compilation-error-regexp-alist)
(defvar compilation-error-regexp-alist-alist)
(setq compilation-error-regexp-alist-alist
(assq-delete-all 'ocaml compilation-error-regexp-alist-alist))
(push rule compilation-error-regexp-alist-alist)
(setq compilation-error-regexp-alist
(delq 'ocaml compilation-error-regexp-alist))
(push 'ocaml compilation-error-regexp-alist)))
;; `tuareg--end-column' is autoloaded because it is used in the
;; compilation pattern rule above.
;;;###autoload
(defun tuareg--end-column ()
"Return the end-column number in a parsed OCaml message.
OCaml uses exclusive end-columns but Emacs wants them to be inclusive."
(and (match-beginning 7)
(+ (string-to-number (match-string 7))
;; Prior to Emacs 28, the end-column function value was incorrectly
;; off by one.
(if (>= emacs-major-version 28) -1 0))))
(setq compilation-error-regexp-alist
(delq 'ocaml compilation-error-regexp-alist))
(push 'ocaml compilation-error-regexp-alist)
(with-eval-after-load 'caml
;; Older versions of caml-mode also change
;; `compilation-error-regexp-alist' with a too simple regexp.
;; Make sure the one above comes first.
(setq compilation-error-regexp-alist
(delq 'ocaml compilation-error-regexp-alist))
(push 'ocaml compilation-error-regexp-alist))
(autoload 'ocaml-module-alist "caml-help")
(autoload 'ocaml-visible-modules "caml-help")
(autoload 'ocaml-module-symbols "caml-help")
(defun tuareg-completion-at-point ()
(let ((beg (save-excursion (skip-syntax-backward "w_") (point)))
(end (save-excursion (skip-syntax-forward "w_") (point)))
(table
(lambda (string pred action)
(let ((dot (string-match-p "\\.[^.]*\\'" string))
;; ocaml-module-symbols contains an unexplained call to
;; pop-to-buffer within save-window-excursion. Let's try and
;; avoid it pops up a stupid frame.
(display-buffer-alist
(cons '("^\\*caml-help\\*$"
(display-buffer-reuse-window
display-buffer-pop-up-window)
(reusable-frames . nil); only the selected frame
(window-height . 0.25))
display-buffer-alist)))
(if (eq (car-safe action) 'boundaries)
`(boundaries ,(if dot (1+ dot) 0)
,@(string-match-p "\\." (cdr action)))
(if (null dot)
(complete-with-action
action (apply #'append
(mapcar (lambda (mod) (concat (car mod) "."))
(ocaml-module-alist))
(mapcar #'ocaml-module-symbols
(ocaml-visible-modules)))
string pred)
(completion-table-with-context
(substring string 0 (1+ dot))
(ocaml-module-symbols
(assoc (substring string 0 dot) (ocaml-module-alist)))
(substring string (1+ dot)) pred action)))))))
(unless (or (eq beg end)
(not tuareg-with-caml-mode-p))
(list beg end table))))
(autoload 'caml-complete "caml-help")
(defun tuareg-complete (arg)
"Completes qualified ocaml identifiers."
(interactive "p")
(modify-syntax-entry ?_ "w" tuareg-mode-syntax-table)
(unwind-protect
(caml-complete arg)
(modify-syntax-entry ?_ "_" tuareg-mode-syntax-table)))
(define-skeleton tuareg-insert-class-form
"Insert a nicely formatted class-end form, leaving a mark after end."
nil
\n "class " @ " = object (self)" > \n
"inherit " > _ " as super" \n "end;;" > \n)
(define-skeleton tuareg-insert-begin-form
"Insert a nicely formatted begin-end form, leaving a mark after end."
nil
\n "begin" > \n _ \n "end" > \n)
(define-skeleton tuareg-insert-for-form
"Insert a nicely formatted for-to-done form, leaving a mark after done."
nil
\n "for " - " do" > \n _ \n "done" > \n)
(define-skeleton tuareg-insert-while-form
"Insert a nicely formatted for-to-done form, leaving a mark after done."
nil
\n "while " - " do" > \n _ \n "done" > \n)
(define-skeleton tuareg-insert-if-form
"Insert a nicely formatted if-then-else form, leaving a mark after else."
nil
\n "if" > \n _ \n "then" > \n @ \n "else" \n @)
(define-skeleton tuareg-insert-match-form
"Insert a nicely formatted math-with form, leaving a mark after with."
nil
\n "match" > \n _ \n "with" > \n)
(define-skeleton tuareg-insert-let-form
"Insert a nicely formatted let-in form, leaving a mark after in."
nil
\n "let " > _ " in" > \n)
(define-skeleton tuareg-insert-try-form
"Insert a nicely formatted try-with form, leaving a mark after with."
nil
\n "try" > \n _ \n "with" > \n)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; OPAM
(when (and tuareg-opam-insinuate tuareg-opam)
(setq tuareg-interactive-program
(concat tuareg-opam " exec -- ocaml"))
(advice-add 'compile :before #'tuareg--compile-opam)
(defvar merlin-command) ;Silence byte-compiler.
(setq merlin-command 'opam)
)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Tuareg interactive mode
;; Augment Tuareg mode with an OCaml REPL.
(require 'comint)
(defvar tuareg-interactive-mode-map
(let ((map (copy-keymap comint-mode-map)))
(define-key map "\C-c\C-i" #'tuareg-interrupt-ocaml)
(define-key map "\C-c\C-k" #'tuareg-kill-ocaml)
(define-key map "\C-c\C-z" #'tuareg-switch-to-recent-buffer)
(define-key map "\C-c`" #'tuareg-interactive-next-error-repl)
(define-key map "\C-c?" #'tuareg-interactive-next-error-repl)
(define-key map "\C-m" #'tuareg-interactive-send-input)
(define-key map [(shift return)]
#'tuareg-interactive-send-input-end-of-phrase)
(define-key map [(ctrl return)]
#'tuareg-interactive-send-input-end-of-phrase)
(define-key map [kp-enter] #'tuareg-interactive-send-input-end-of-phrase)
map))
(defconst tuareg-interactive-buffer-name "*OCaml*")
(defconst tuareg-interactive-error-range-regexp
(rx (* (in "\t "))
(? "Line" (? "s") " "
(group-n 1 (+ (in "0-9"))) ; starting line
(? "-"
(group-n 2 (+ (in "0-9")))) ; ending line
", ")
(in "Cc") "haracters "
(group-n 3 (+ (in "0-9"))) ; starting character
"-"
(group-n 4 (+ (in "0-9"))) ; ending character
":\n")
"Regexp matching the line and char numbers in OCaml REPL's error messages.")
(defun tuareg--interactive-error-range (base-pos text-buffer)
"Decode range in `tuareg-interactive-error-range-regexp' match.
BASE-POS is the start, in TEXT-BUFFER, of the text to
which the matched error refers. Return (BEG-POS . END-POS)."
(let* ((match-num (lambda (group)
(and (match-beginning group)
(string-to-number (match-string group)))))
(beg-line (funcall match-num 1))
(end-line (funcall match-num 2))
(beg-char (funcall match-num 3))
(end-char (funcall match-num 4)))
(with-current-buffer text-buffer
(save-excursion
(goto-char base-pos)
(when (and beg-line (> beg-line 1))
(forward-line (1- beg-line)))
(forward-char beg-char)
(let ((beg-pos (point)))
(if end-line
(progn
(forward-line (- end-line beg-line))
(forward-char end-char))
(forward-char (- end-char beg-char)))
(let ((end-pos (point)))
(cons beg-pos end-pos)))))))
(defconst tuareg-interactive-error-regexp
"\n\\(Error: [^#]*\\)")
(defconst tuareg-interactive-exception-regexp
"\\(Exception: [^#]*\\)")
(defvar tuareg-interactive-last-phrase-pos-in-source 0)
(defvar tuareg-interactive-last-phrase-pos-in-repl 0)
(defun tuareg-interactive-filter (_text)
(when (eq major-mode 'tuareg-interactive-mode)
(save-excursion
(when (>= comint-last-input-end comint-last-input-start)
(when tuareg-interactive-read-only-input
(add-text-properties
comint-last-input-start comint-last-input-end
(list 'read-only t)))
(when (and font-lock-mode tuareg-interactive-input-font-lock)
(font-lock-fontify-region comint-last-input-start
comint-last-input-end))
(when tuareg-interactive-output-font-lock
(save-excursion
(goto-char (point-max))
(re-search-backward comint-prompt-regexp
comint-last-input-end t)
(add-text-properties
comint-last-input-end (point)
'(font-lock-face tuareg-font-lock-interactive-output-face))))
(when tuareg-interactive-error-font-lock
(save-excursion
(goto-char comint-last-input-end)
(cond
((looking-at tuareg-interactive-error-range-regexp)
(let* ((range (tuareg--interactive-error-range
comint-last-input-start (current-buffer)))
(beg (car range))
(end (cdr range)))
(put-text-property
beg end 'font-lock-face 'tuareg-font-lock-error-face))
(goto-char comint-last-input-end)
(when (re-search-forward tuareg-interactive-error-regexp nil t)
(let ((errbeg (match-beginning 1))
(errend (match-end 1)))
(put-text-property
errbeg errend
'font-lock-face 'tuareg-font-lock-interactive-error-face))))
((looking-at tuareg-interactive-exception-regexp)
(let ((errbeg (match-beginning 1))
(errend (match-end 1)))
(put-text-property
errbeg errend
'font-lock-face 'tuareg-font-lock-interactive-error-face)))
)))))))
(defun tuareg-switch-to-repl (eob-p)
"Switch to the inferior OCaml process buffer.
With prefix argument EOB-P, positions cursor at end of buffer."
(interactive "P")
(let ((repl-buffer (get-buffer tuareg-interactive-buffer-name)))
(if (get-buffer-process repl-buffer)
(pop-to-buffer repl-buffer)
;; start a new REPL if one is not running already
(call-interactively #'tuareg-run-ocaml)))
(when eob-p
(push-mark)
(goto-char (point-max))))
(defun tuareg-switch-to-recent-buffer ()
"Switch to the most recently used `tuareg-mode' buffer."
(interactive)
(let ((recent-ocaml-buffer
(cl-find-if (lambda (buf)
(with-current-buffer buf (derived-mode-p 'tuareg-mode)))
(buffer-list))))
(if recent-ocaml-buffer
(pop-to-buffer recent-ocaml-buffer)
(message "Tuareg: No recent Ocaml buffer found."))))
(easy-menu-define
tuareg-interactive-mode-menu tuareg-interactive-mode-map
"Tuareg Interactive Mode Menu."
'("Tuareg"
("Interactive Mode"
["Run OCaml REPL" tuareg-run-ocaml t]
["Interrupt OCaml REPL" tuareg-interrupt-ocaml
:active (comint-check-proc tuareg-interactive-buffer-name)]
["Kill OCaml REPL" tuareg-kill-ocaml
:active (comint-check-proc tuareg-interactive-buffer-name)]
["Switch to Recent Source Buffer" tuareg-switch-to-recent-buffer
:active (comint-check-proc tuareg-interactive-buffer-name)]
["Evaluate Region" tuareg-eval-region :active (region-active-p)]
["Evaluate Phrase" tuareg-eval-phrase t]
["Evaluate Buffer" tuareg-eval-buffer t])
"---"
["Customize Tuareg Mode..." (customize-group 'tuareg) t]
("Tuareg Options" ["Dummy" nil t])
("Tuareg Interactive Options" ["Dummy" nil t])
"---"
["Help" tuareg-interactive-help t]))
(define-derived-mode tuareg-interactive-mode comint-mode "Tuareg-Interactive"
"Major mode for interacting with an OCaml process.
Runs an OCaml REPL as a subprocess of Emacs, with I/O through an
Emacs buffer. A history of input phrases is maintained. Phrases can
be sent from another buffer in tuareg mode.
Short cuts for interactions with the REPL:
\\{tuareg-interactive-mode-map}"
(add-hook 'comint-output-filter-functions #'tuareg-interactive-filter)
(setq comint-prompt-regexp "^# *")
(setq comint-process-echoes nil)
(setq comint-get-old-input 'tuareg-interactive-get-old-input)
(setq comint-scroll-to-bottom-on-output
tuareg-interactive-scroll-to-bottom-on-output)
(set-syntax-table tuareg-mode-syntax-table)
(setq-local comment-start "(* ")
(setq-local comment-end " *)")
(setq-local comment-start-skip "(\\*+[ \t]*")
(setq-local comint-prompt-read-only t)
(tuareg--common-mode-setup)
(tuareg--install-font-lock t)
(when (or tuareg-interactive-input-font-lock
tuareg-interactive-output-font-lock
tuareg-interactive-error-font-lock)
(font-lock-mode 1))
(tuareg-update-options-menu))
;;;###autoload
(defun tuareg-run-ocaml ()
"Run an OCaml REPL process. I/O via buffer `*OCaml*'."
(interactive)
(tuareg-run-process-if-needed)
(display-buffer tuareg-interactive-buffer-name))
;;;###autoload
(defalias 'run-ocaml #'tuareg-run-ocaml)
;;;###autoload
(add-to-list 'interpreter-mode-alist '("ocamlrun" . tuareg-mode))
;;;###autoload
(add-to-list 'interpreter-mode-alist '("ocaml" . tuareg-mode))
(defun tuareg-run-process-if-needed (&optional cmd)
"Run an OCaml REPL process if needed, with an optional command name.
I/O via buffer `*OCaml*'."
(if cmd
(setq tuareg-interactive-program cmd)
(unless (comint-check-proc tuareg-interactive-buffer-name)
(setq tuareg-interactive-program
(read-shell-command "OCaml REPL to run: "
tuareg-interactive-program))))
(unless (comint-check-proc tuareg-interactive-buffer-name)
(let ((cmdlist (tuareg--split-args tuareg-interactive-program))
(process-connection-type t))
(set-buffer (apply (function make-comint) "OCaml"
(car cmdlist) nil (cdr cmdlist)))
(tuareg-interactive-mode)
(sleep-for 1))))
(defun tuareg--split-args (args)
(condition-case nil
(split-string-and-unquote args)
(error (progn
(message "Arguments ‘%s’ ill quoted. Ignored." args)
nil))))
(defun tuareg-interactive-get-old-input ()
(save-excursion
(let ((end (point)))
(re-search-backward comint-prompt-regexp (point-min) t)
(when (looking-at comint-prompt-regexp)
(re-search-forward comint-prompt-regexp))
(buffer-substring-no-properties (point) end))))
(defconst tuareg-interactive--send-warning
"Note: REPL processing requires a terminating `;;', or use S-return.")
(defun tuareg-interactive--indent-line ()
(insert "\n")
(indent-according-to-mode)
(message tuareg-interactive--send-warning))
(defun tuareg-interactive-send-input ()
"Send the current phrase to the OCaml REPL or insert a newline.
If the point is next to \";;\", the phrase is sent to the REPL,
otherwise a newline is inserted and the lines are indented."
(interactive)
(cond
((tuareg-in-literal-or-comment-p) (tuareg-interactive--indent-line))
((or (equal ";;" (save-excursion (nth 2 (smie-backward-sexp))))
(looking-at-p "[ \t\n\r]*;;"))
(comint-send-input))
(t (tuareg-interactive--indent-line))))
(defun tuareg-interactive-send-input-end-of-phrase ()
(interactive)
(goto-char (point-max))
(unless (equal ";;" (save-excursion (nth 2 (smie-backward-sexp))))
(insert ";;"))
(comint-send-input))
(defun tuareg-interactive--send-region (start end)
"Send the region between START and END to the OCaml REPL.
It is assumed that the range START-END delimit valid OCaml phrases."
(save-excursion (tuareg-run-process-if-needed))
(comint-preinput-scroll-to-bottom)
(setq tuareg-interactive-last-phrase-pos-in-source start)
(let* ((phrases (buffer-substring-no-properties start end))
(phrases (replace-regexp-in-string "[ \t\n]*\\(;;[ \t\n]*\\)?\\'" ""
phrases))
(phrases-semicolon (concat phrases ";;")))
(if (string= phrases "")
(message "Cannot send empty commands to OCaml REPL!")
(with-current-buffer tuareg-interactive-buffer-name
(goto-char (point-max))
(setq tuareg-interactive-last-phrase-pos-in-repl (point))
(comint-send-string tuareg-interactive-buffer-name phrases-semicolon)
(let ((pos (point)))
(comint-send-input)
(when tuareg-interactive-echo-phrase
(save-excursion
(goto-char pos)
(insert phrases-semicolon)))))))
(when tuareg-display-buffer-on-eval
(display-buffer tuareg-interactive-buffer-name)))
(defun tuareg-eval-region (start end)
"Eval the current region in the OCaml REPL."
(interactive "r")
(tuareg-interactive--send-region start end))
(define-obsolete-function-alias 'tuareg-narrow-to-phrase #'narrow-to-defun
"Apr 10, 2019")
(defun tuareg-eval-phrase ()
"Eval the surrounding OCaml phrase (or block) in the OCaml REPL.
If the region is active, evaluate all phrases intersecting the region."
(interactive)
(let ((opoint (point))
start end)
(cond
((region-active-p)
(let ((rbeg (region-beginning))
(rend (region-end)))
(setq start rbeg)
(setq end rend)
;; Extend the region at the endpoints if they are in a phrase.
(save-excursion
(dolist (pos (list rbeg rend))
(goto-char pos)
(let* ((phrase (tuareg-discover-phrase))
(beg-phrase (car phrase))
(end-phrase (cadr phrase)))
(when (and phrase
(> end-phrase rbeg)
(< beg-phrase rend))
;; A phrase intersects the region; extend.
(setq start (min start beg-phrase))
(setq end (max end end-phrase))))))))
(t
(let ((phrase (tuareg-discover-phrase)))
(unless phrase
(user-error "Expression after the point is not well braced"))
(setq start (car phrase))
(setq end (cadr phrase)))))
(tuareg-interactive--send-region start end)
(if tuareg-skip-after-eval-phrase
(progn
(when (region-active-p)
;; We are moving point and the user probably doesn't
;; expect the region to be affected.
(deactivate-mark))
(goto-char end)
(tuareg-skip-blank-and-comments))
(goto-char opoint))))
(defun tuareg-eval-buffer ()
"Send the buffer to the Tuareg Interactive process."
(interactive)
(tuareg-interactive--send-region (point-min) (point-max)))
(defvar tuareg-interactive-next-error-olv (make-overlay 1 1))
(overlay-put tuareg-interactive-next-error-olv
'face 'tuareg-font-lock-error-face)
(delete-overlay tuareg-interactive-next-error-olv)
(defun tuareg-interactive-next-error-source ()
(interactive)
(let* ((source-buffer (current-buffer))
(range
(with-current-buffer tuareg-interactive-buffer-name
(goto-char tuareg-interactive-last-phrase-pos-in-repl)
(and (re-search-forward tuareg-interactive-error-range-regexp nil t)
(tuareg--interactive-error-range
tuareg-interactive-last-phrase-pos-in-source
source-buffer)))))
(if (not range)
(message "No syntax or typing error in last phrase.")
(let ((beg (car range))
(end (cdr range)))
(goto-char beg)
(move-overlay tuareg-interactive-next-error-olv beg end)
(unwind-protect
(sit-for 60 t)
(delete-overlay tuareg-interactive-next-error-olv))))))
(defun tuareg-interactive-next-error-repl ()
(interactive)
(let ((range
(save-excursion
(goto-char tuareg-interactive-last-phrase-pos-in-repl)
(and (re-search-forward tuareg-interactive-error-range-regexp nil t)
(tuareg--interactive-error-range
tuareg-interactive-last-phrase-pos-in-repl
(current-buffer))))))
(if (not range)
(message "No syntax or typing error in last phrase.")
(let ((beg (car range))
(end (cdr range)))
(move-overlay tuareg-interactive-next-error-olv beg end)
(unwind-protect
(sit-for 60 t)
(delete-overlay tuareg-interactive-next-error-olv))
(goto-char beg)))))
(defun tuareg-interrupt-ocaml ()
(interactive)
(when (comint-check-proc tuareg-interactive-buffer-name)
(with-current-buffer tuareg-interactive-buffer-name
(comint-interrupt-subjob))))
(defun tuareg-kill-ocaml ()
(interactive)
(when (comint-check-proc tuareg-interactive-buffer-name)
(with-current-buffer tuareg-interactive-buffer-name
(comint-kill-subjob))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Menu support
(defun tuareg-short-cuts ()
"Short cuts for the Tuareg mode:
\\{tuareg-mode-map}
Short cuts for interaction within the REPL:
\\{tuareg-interactive-mode-map}"
(interactive)
(describe-function 'tuareg-short-cuts))
(defun tuareg-help ()
(interactive)
(describe-function 'tuareg-mode))
(defun tuareg-interactive-help ()
(interactive)
(describe-function 'tuareg-interactive-mode))
(defun tuareg-build-menu ()
(easy-menu-define
tuareg-mode-menu (list tuareg-mode-map)
"Tuareg Mode Menu."
'("Tuareg"
("Interactive Mode"
["Run OCaml REPL" tuareg-run-ocaml t]
["Switch to OCaml REPL" tuareg-switch-to-repl
:active (comint-check-proc tuareg-interactive-buffer-name)]
["Interrupt OCaml REPL" tuareg-interrupt-ocaml
:active (comint-check-proc tuareg-interactive-buffer-name)]
["Kill OCaml REPL" tuareg-kill-ocaml
:active (comint-check-proc tuareg-interactive-buffer-name)]
["Evaluate Region" tuareg-eval-region
:active (use-region-p)]
["Evaluate Phrase" tuareg-eval-phrase t]
["Evaluate Buffer" tuareg-eval-buffer t])
("OCaml Forms"
["try .. with .." tuareg-insert-try-form t]
["match .. with .." tuareg-insert-match-form t]
["let .. in .." tuareg-insert-let-form t]
["if .. then .. else .." tuareg-insert-if-form t]
["while .. do .. done" tuareg-insert-while-form t]
["for .. do .. done" tuareg-insert-for-form t]
["begin .. end" tuareg-insert-begin-form t])
["Switch .ml/.mli" tuareg-find-alternate-file t]
"---"
["Compile..." compile t]
["Reference Manual..." tuareg-browse-manual t]
["OCaml Library..." tuareg-browse-library t]
"---"
[ "Show type at point" caml-types-show-type
tuareg-with-caml-mode-p]
[ "Show fully qualified ident at point" caml-types-show-ident
tuareg-with-caml-mode-p]
[ "Show the kind of call at point" caml-types-show-call
tuareg-with-caml-mode-p]
"---"
[ "Complete identifier" caml-complete
tuareg-with-caml-mode-p]
[ "Help for identifier" caml-help
tuareg-with-caml-mode-p]
[ "Add path for documentation" ocaml-add-path
tuareg-with-caml-mode-p]
[ "Open module for documentation" ocaml-open-module
tuareg-with-caml-mode-p]
[ "Close module for documentation" ocaml-close-module
tuareg-with-caml-mode-p]
"---"
["Customize Tuareg Mode..." (customize-group 'tuareg) t]
("Tuareg Options" ["Dummy" nil t])
("Tuareg Interactive Options" ["Dummy" nil t])
"---"
["Short Cuts" tuareg-short-cuts]
["Help" tuareg-help t]))
(tuareg-update-options-menu))
(defun tuareg-toggle-option (symbol)
(interactive)
(set symbol (not (symbol-value symbol)))
(tuareg-update-options-menu))
(defun tuareg-update-options-menu ()
(easy-menu-change
'("Tuareg") "Tuareg Options"
(mapcar (lambda (pair)
(if (consp pair)
(vector (car pair)
(list 'tuareg-toggle-option (cdr pair))
':style 'toggle
':selected (nth 1 (cdr pair))
':active t)
pair))
tuareg-options-list))
(easy-menu-change
'("Tuareg") "Tuareg Interactive Options"
(mapcar (lambda (pair)
(if (consp pair)
(vector (car pair)
(list 'tuareg-toggle-option (cdr pair))
':style 'toggle
':selected (nth 1 (cdr pair))
':active t)
pair))
tuareg-interactive-options-list)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Browse Manual
;; From M. Quercia
(defun tuareg-browse-manual ()
"Browse OCaml reference manual."
(interactive)
(setq tuareg-manual-url (read-from-minibuffer "URL: " tuareg-manual-url))
(funcall tuareg-browser tuareg-manual-url))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Browse Library
;; From M. Quercia
(defvar tuareg-library-mode-map
(let ((map (make-keymap)))
(suppress-keymap map)
(define-key map [return] #'tuareg-library-find-file)
(define-key map [mouse-2] #'tuareg-library-mouse-find-file)
map))
(defun tuareg-browse-library ()
"Browse the OCaml library."
(interactive)
(let ((buf-name "*ocaml-library*") (opoint)
(dir (read-from-minibuffer "Library dir: " tuareg-library-path)))
(when (and (file-directory-p dir) (file-readable-p dir))
(setq tuareg-library-path dir)
;; List *.ml and *.mli files
(with-output-to-temp-buffer buf-name
(buffer-disable-undo standard-output)
(with-current-buffer buf-name
(kill-all-local-variables)
(setq-local tuareg-library-path dir)
;; Help
(insert "Directory \"" dir "\".\n")
(insert "Select a file with middle mouse button or RETURN.\n\n")
(insert "Interface files (.mli):\n\n")
(insert-directory (concat dir "/*.mli") "-C" t nil)
(insert "\n\nImplementation files (.ml):\n\n")
(insert-directory (concat dir "/*.ml") "-C" t nil)
;; '.', '-' and '_' are now letters
(modify-syntax-entry ?. "w")
(modify-syntax-entry ?_ "w")
(modify-syntax-entry ?- "w")
;; Every file name is now mouse-sensitive
(goto-char (point-min))
(while (< (point) (point-max))
(re-search-forward "\\.ml.?\\>")
(setq opoint (point))
(re-search-backward "\\<" (point-min) 1)
(put-text-property (point) opoint 'mouse-face 'highlight)
(goto-char (+ 1 opoint)))
;; Activate tuareg-library mode
(setq major-mode 'tuareg-library-mode)
(setq mode-name "tuareg-library")
(use-local-map tuareg-library-mode-map)
(setq buffer-read-only t))))))
(defun tuareg-library-find-file ()
"Load the file whose name is near point."
(interactive)
(when (text-properties-at (point)) ;FIXME: Why??
(save-excursion
(let (beg)
(re-search-backward "\\<") (setq beg (point))
(re-search-forward "\\>")
(find-file-read-only (expand-file-name (buffer-substring-no-properties
beg (point))
tuareg-library-path))))))
(defun tuareg-library-mouse-find-file (event)
"Visit the file name you click on."
(interactive "e")
(let ((owindow (selected-window)))
(mouse-set-point event)
(tuareg-library-find-file)
(select-window owindow)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Imenu support
(defun tuareg-imenu-create-index ()
"Create an index alist for OCaml files using `merlin-imenu' or `caml-mode'.
See `imenu-create-index-function'."
(or (require 'merlin-imenu nil t)
(let (abbrevs-changed) ;Workaround for tuareg#146
(require 'caml nil t)))
(cond
((fboundp 'merlin-imenu-create-index)
(merlin-imenu-create-index))
((fboundp 'caml-create-index-function)
(caml-create-index-function))
(t
(message "Install Merlin or caml-mode.")
;; Cannot return the empty list `nil' because imenu will issue its
;; own warning.
'(("Install Merlin or caml-mode" . 0)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Related files & modes
(with-eval-after-load 'speedbar
(declare-function speedbar-add-supported-extension "speedbar" (extension))
(defvar speedbar-obj-alist)
(speedbar-add-supported-extension
'(".ml" ".mli" ".mll" ".mly" ".mlp" ".ls"))
(push '("\\.mli\\'" . ".cmi") speedbar-obj-alist)
(push '("\\.ml\\'" . ".cmo") speedbar-obj-alist))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Hooks and Exit
(provide 'tuareg)
;;; tuareg.el ends here
tuareg-3.0.1/tuareg.opam 0000664 0000000 0000000 00000002371 14315315656 0015163 0 ustar 00root root 0000000 0000000 opam-version: "2.0"
maintainer: "Christophe.Troestler@umons.ac.be"
authors: [
"Albert Cohen "
"Sam Steingold "
"Christophe Troestler "
"Stefan Monnier "
]
license: "GPL-2.0-or-later"
homepage: "https://github.com/ocaml/tuareg"
bug-reports: "https://github.com/ocaml/tuareg/issues"
dev-repo: "git+https://github.com/ocaml/tuareg.git"
doc: "https://github.com/ocaml/tuareg"
build: [
[make "tuareg-site-file.el"]
[make "elc"] { os != "macos" }
]
depends: ["ocaml" "conf-emacs"]
depopts: [
"caml-mode" {>= "4.9"}
"merlin"
]
post-messages: [
"If you have not yet done so, please add the following line to ~/.emacs.d/init.el or ~/.emacs:
(load \"%{share}%/emacs/site-lisp/tuareg-site-file\")
" {success & !user-setup:installed}
"You should consider installing \"merlin\" (completion, displaying types,...)
or \"caml-mode\" (displaying types). See https://github.com/ocaml/tuareg
for customization tips."
]
synopsis: "OCaml mode for GNU Emacs"
description: """
Tuareg handles automatic indentation of OCaml and Camllight codes.
Key parts of the code are highlighted using Font-Lock. Support to run
an interactive OCaml REPL and debugger is provided."""