pgqa-0.1/ 0000755 0001751 0000144 00000000000 13376770703 010627 5 ustar ah users pgqa-0.1/COPYING 0000644 0001751 0000144 00000104513 13376770702 011665 0 ustar ah users 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
.
pgqa-0.1/pgqa-test.el 0000644 0001751 0000144 00000013133 13376770702 013056 0 ustar ah users ;; Copyright (C) 2016 Antonin Houska
;;
;; This file is part of PGQA.
;;
;; PGQA 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.
;; PGQA 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 qalong
;; with PGQA. If not, see .
(require 'pgqa)
(defun pgqa-run-single-formatting-test (&optional indent)
(let ((state))
(pgqa-check-customizations)
(pgqa-parse)
(setq state (pgqa-deparse-batch indent))
(princ (oref state result))))
(defun prepare-next-test ()
(erase-buffer)
(insert input-text)
(pgqa-mode))
(defun pgqa-test-formatting ()
"Test query formatting using various values of the related custom variables."
(if (null noninteractive)
(user-error "pgqa-format-query-batch function should only be used in
batch mode"))
(let ((input-text (buffer-string)))
(pgqa-mode)
(setq pgqa-multiline-query nil)
(setq pgqa-multiline-join nil)
(setq pgqa-join-newline nil)
(setq pgqa-multiline-operator nil)
(setq fill-column 40)
(pgqa-run-single-formatting-test)
(prepare-next-test)
(setq pgqa-multiline-query t)
(setq pgqa-multiline-join nil)
(setq pgqa-join-newline nil)
(setq pgqa-multiline-operator nil)
(princ "\n\n")
(pgqa-run-single-formatting-test)
(prepare-next-test)
(setq pgqa-multiline-query t)
(setq pgqa-multiline-join t)
(setq pgqa-join-newline nil)
(setq pgqa-multiline-operator nil)
(princ "\n\n")
(pgqa-run-single-formatting-test)
(prepare-next-test)
(setq pgqa-multiline-query t)
(setq pgqa-multiline-join t)
(setq pgqa-join-newline t)
(setq pgqa-multiline-operator nil)
(princ "\n\n")
(pgqa-run-single-formatting-test)
(prepare-next-test)
(setq pgqa-multiline-query t)
(setq pgqa-multiline-join t)
(setq pgqa-join-newline t)
;; Whether particular test contains CASE expression or not, we must set
;; both pgqa-multiline-case and pgqa-multiline-case-branch in order to
;; satisfy the dependencies of pgqa-multiline-operator.
(setq pgqa-multiline-case t)
(setq pgqa-multiline-case-branch t)
(setq pgqa-multiline-operator t)
;; The batch mode defaults to 70 for some reason, but it'd disturb some
;; tests of pgqa-multiline-operator.
(setq fill-column 78)
(princ "\n\n")
(pgqa-run-single-formatting-test)
;; pgqa-clause-newline with pgqa-multiline-operator not set.
(prepare-next-test)
(setq pgqa-multiline-query t)
(setq pgqa-multiline-join t)
(setq pgqa-join-newline t)
(setq pgqa-multiline-operator nil)
(setq pgqa-clause-newline t)
(princ "\n\n")
(pgqa-run-single-formatting-test)
;; pgqa-clause-newline with pgqa-multiline-operator set.
(prepare-next-test)
(setq pgqa-multiline-query t)
(setq pgqa-multiline-join t)
(setq pgqa-join-newline t)
(setq pgqa-multiline-case t)
(setq pgqa-multiline-case-branch t)
(setq pgqa-multiline-operator t)
(setq fill-column 78)
(setq pgqa-clause-newline t)
(princ "\n\n")
(pgqa-run-single-formatting-test)
(prepare-next-test)
(setq tab-width 4)
(princ "\n\n")
(pgqa-run-single-formatting-test)
;; This test differs from the previous one by
;; pgqa-clause-newline. (pgqa-multiline-operator is cleared too, to make
;; the effect of pgqa-clause-newline visible). The test verifies that:
;; 1. the top level clause receives extra indentation if the "top keyword"
;; (e.g. GROUP BY) reaches behind the first tab position, 2. all the lines
;; of the clause obey this indentation - this is why we adjust fill-column
;; too.
(prepare-next-test)
(setq tab-width 4)
(setq pgqa-multiline-query t)
(setq pgqa-multiline-join t)
(setq pgqa-join-newline t)
(setq pgqa-multiline-operator nil)
(setq pgqa-clause-newline nil)
(setq fill-column 20)
(princ "\n\n")
(pgqa-run-single-formatting-test)
;; pgqa-clause-item-newline
(prepare-next-test)
(setq pgqa-multiline-query t)
(setq pgqa-multiline-join t)
(setq pgqa-join-newline t)
(setq pgqa-multiline-operator nil)
(setq pgqa-clause-newline t)
(setq pgqa-clause-item-newline t)
(princ "\n\n")
(pgqa-run-single-formatting-test)
;; The same, with pgqa-multiline-operator set.
(prepare-next-test)
(setq pgqa-multiline-case t)
(setq pgqa-multiline-case-branch t)
(setq pgqa-multiline-operator t)
(setq fill-column 78)
(princ "\n\n")
(pgqa-run-single-formatting-test)
;; Tests of non-zero indentation.
(setq pgqa-multiline-query nil)
(setq pgqa-multiline-join nil)
(setq pgqa-join-newline nil)
(setq pgqa-multiline-case nil)
(setq pgqa-multiline-case-branch nil)
(setq pgqa-multiline-operator nil)
(setq pgqa-clause-newline nil)
(setq pgqa-clause-item-newline nil)
(princ "\n\n")
(pgqa-run-single-formatting-test 2)
(setq pgqa-multiline-query t)
(princ "\n\n")
(pgqa-run-single-formatting-test 2)
(setq pgqa-clause-newline t)
(setq pgqa-multiline-join t)
(setq pgqa-multiline-case t)
(setq pgqa-multiline-case-branch t)
(setq pgqa-multiline-operator t)
(setq fill-column 78)
(princ "\n\n")
(pgqa-run-single-formatting-test 2)))
pgqa-0.1/pgqa-analyze.el 0000644 0001751 0000144 00000014555 13376770702 013553 0 ustar ah users ;; Copyright (C) 2016N Antonin Houska
;;
;; This file is part of PGQA.
;;
;; PGQA 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.
;; PGQA 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 qalong
;; with PGQA. If not, see .
(require 'pgqa-node)
(defclass pgqa-problem ()
(
(message
:initarg :message
"Message that user should see")
(location
:initarg :location
"Integer (marker) position the problem was found at, or a vector containing both start and end position.")
)
"A problem identified during query analysis."
)
(defclass pgqa-analyze-context ()
(
(problems
:initarg :problems
:initform nil
:documentation "List of errors / warnings encountered during analysis."
)
)
"Information passed across query tree nodes during analysis."
)
(defun pgqa-show-problems (problems buffer)
"Show problems in the appropriate buffer."
;; Make sure that the output buffer exists.
(setq pgqa-log-buffer (get-buffer-create pgqa-log-buffer))
;; Display the errors / warnings.
(with-current-buffer pgqa-log-buffer
(atomic-change-group
(setq buffer-read-only nil)
(erase-buffer)
(if (car problems)
(progn
(let ((button)
(pos)
(i 0))
(dolist (p problems)
;; Separate the message from the previous one.
(if (> i 0)
(insert "\n"))
(setq pos (point))
(insert (format "%s\n" (oref p message)))
(when (null noninteractive)
;; Create a text button so that user can navigate to the
;; related node by clicking on the problem text.
(setq button
(make-text-button pos (1- (point))))
;; Set the location of the problem is available to the
;; action function(s).
(button-put button 'err-loc (oref p location))
(button-put button 'query-buffer buffer)
;; Mouse click should also lead to the problem location.
(button-put button 'follow-link t)
(button-put button 'action
(lambda (button)
(let* ((loc (button-get button 'err-loc))
(buf (button-get button
'query-buffer)))
;; Point at the problem location.
(with-current-buffer buf
(switch-to-buffer-other-window
(current-buffer))
(if (sequencep loc)
;; Both start and end position is
;; known.
(progn
(goto-char (elt loc 0))
;; TODO Use save-mark-and-excursion
(push-mark)
;; Mark the problem location.
(activate-mark)
(goto-char (elt loc 1))
;; Wait a little bit before
;; deactivating the mark.
(run-at-time ".5 sec" nil
(lambda ()
(goto-char (mark))
(pop-mark))))
;; Only the start position is known.
(goto-char loc))
)
)
)
)
)
;; Get ready for the next message.
(setq pos (point))
(setq i (1+ i)))
)
;; Let user see the buffer.
(switch-to-buffer-other-window (current-buffer)))
(insert "No problems found"))
;; Mark the buffer read-only so that user does not mess it up when
;; hitting ENTER to navigate to the error locations.
(setq buffer-read-only t))
)
(when (car problems)
;; Do not let the processing continue, for whatever reason the function
;; is called. This must happen outside atomic-change-group so that the
;; pgqa-log-buffer setup is not undone.
;;
;; Actually not all problems identified during the analysis break
;; query formatting, however if we proceeded, then the links to
;; the query text would become invalid.
;;
;; XXX In the batch mode, print out the contents of
;; pgqa-log-buffer to standard output.
(user-error "%d problem(s) found in the query" (length problems)))
)
(defmethod pgqa-analyze-node ((node pgqa-node) context)
"Analyze query tree node and add error message / warning to the output list.
Note that new errors are added to the beginning of the list as it seems to be
cheaper. If the order matters, caller can simply call `reverse' on the result."
;; If particular node subclass does not have this method defined, no
;; analysis will take place.
)
(defmethod pgqa-analyze-node ((node pgqa-from-list-entry) context)
(let ((out-list (oref context problems)))
;; Parser should currently enforce the alias, but the error message is not
;; too user friendly. So we might allow absence of the alias in the
;; grammar someday and the analyzer complain here.
(when (string= (oref node kind) "query")
(if (null (slot-boundp node 'alias))
(push
(make-instance 'pgqa-problem
:message "Subquery must have an alizs"
:location node)
out-list))
(let ((alias (oref node alias)))
(when (slot-boundp alias 'cols)
(let* (
;; The actual query is the first arg of the FROM list entry
;; node.
(query (car (oref node args)))
(query-tlist (oref query target-expr))
(query-cols (oref query-tlist args))
(cols-tmp query-cols)
(has-asterisk))
;; If the targetlist contanis an asterisk, we don't know how many
;; output columns the query actually has.
(while (and (null has-asterisk) cols-tmp)
(let ((expr (oref (car cols-tmp) expr)))
(cl-assert (eq (eieio-object-class expr) 'pgqa-obj)
"Target list entry has wrong data type.")
(dolist (e (oref expr args))
(if (string= e "*")
(setq has-asterisk t))
)
)
(setq cols-tmp (cdr cols-tmp)))
(unless has-asterisk
(let* ((ncols-query (length query-cols))
(arg-list (oref alias cols))
(ncols-alias (length (oref arg-list args))))
(if (>
ncols-alias
ncols-query)
(push
(make-instance
'pgqa-problem
:message
(format
"Subquery has %d columns available but %d columns specified in the alias"
ncols-query ncols-alias)
:location (oref alias region))
out-list))
)
)
)
)
)
(oset context problems out-list))
)
)
(provide 'pgqa-analyze)
pgqa-0.1/pgqa-dump.el 0000644 0001751 0000144 00000134560 13376770703 013055 0 ustar ah users ;; Copyright (C) 2016 Antonin Houska
;;
;; This file is part of PGQA.
;;
;; PGQA 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.
;; PGQA 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 qalong
;; with PGQA. If not, see .
(require 'eieio)
(require 'pgqa-node)
(defcustom pgqa-multiline-query t
"If non-nil, query will be deparsed in structured format that spans multiple
lines."
:type 'boolean
:group 'pgqa
)
(defcustom pgqa-multiline-join t
"If non-nil, the JOIN operator (including the INNER, LEFT, etc. predicate)
will always start on a new line.
Can only be set if `pgqa-multiline-query' variable is set."
:type 'boolean
:group 'pgqa
)
(defcustom pgqa-join-newline t
"If non-nil, the tables joined (i.e. not only the JOIN operator) start on a
new line.
If either side of the join requires parentheses (i.e. it's a sub-query or a
join), it starts on a new line regardless this setting.
Can only be set if `pgqa-multiline-join' variable is set."
:type 'boolean
:group 'pgqa
)
(defcustom pgqa-clause-newline nil
"If non-nil, each query clause starts on a new line
Can only be set if `pgqa-multiline-query' variable is set."
:type 'boolean
:group 'pgqa
)
(defcustom pgqa-clause-item-newline nil
"If non-nil, each item of query clause starts on a new line
If the item requires parentheses (i.e. it's a sub-query or a join), this
setting is always considered t.
Can only be set if `pgqa-clause-newline' variable is set."
:type 'boolean
:group 'pgqa
)
(defcustom pgqa-multiline-operator nil
"If non-nil, operators will be deparsed in a structured way.
Can only be set if both `pgqa-multiline-query' and `pgqa-multiline-join'
variables are set."
:type 'boolean
:group 'pgqa
)
(defcustom pgqa-multiline-case nil
"If non-nil, each branch of the CASE expression will start on a new line.
Can only be set if both `pgqa-multiline-query' and `pgqa-multiline-join'
variables are set."
:type 'boolean
:group 'pgqa
)
(defcustom pgqa-multiline-case-branch nil
"If non-nil, THEN keyword of the CASE expression will start on a new line.
Can only be set if `pgqa-multiline-case'is set."
:type 'boolean
:group 'pgqa
)
(defcustom pgqa-clause-keyword-right nil
"If non-nil, the clause keyword (SELECT, FROM, WHERE, etc.) will be right
aligned
Can only be set if `pgqa-multiline-query' is set."
:type 'boolean
:group 'pgqa)
(defcustom pgqa-print-as t
"If non-nil, expression alias is denoted by the AS keyword."
:type 'boolean
:group 'pgqa)
;; TODO Rename so that it's formatting-specific.
(defun pgqa-check-customizations ()
"Throw `user-error' if value of any custom variable is illegal."
(if pgqa-multiline-join
(if (null pgqa-multiline-query)
(user-error "`pgqa-multiline-join' requires
`pgqa-multiline-query'")))
(if pgqa-join-newline
(if (null pgqa-multiline-join)
(user-error "`pgqa-join-newline' requires `pgqa-multiline-join'")))
(if pgqa-multiline-case-branch
(if (null pgqa-multiline-case)
(user-error "`pgqa-multiline-case-branch' requires `pgqa-multiline-case'")))
(if pgqa-multiline-operator
;; If the JOIN keyword or the THEN keyword of the CASE expression
;; followed an operator expression in the ON clause which is printed out
;; in the multiline form, it would become incorrectly indented.
;;
;; XXX pgqa-multiline-query is redundant here now, but I'm not sure if
;; this dependency should be removed. If pgqa-multiline-join became
;; unnecessary for pgqa-multiline-operator someday, pgqa-multiline-query
;; would have to be added again.
(if (or (null pgqa-multiline-query) (null pgqa-multiline-join)
(null pgqa-multiline-case-branch))
(user-error "`pgqa-multiline-operator' requires all `pgqa-multiline-query' and `pgqa-multiline-join' and `pgqa-multiline-case-branch'")))
(if pgqa-multiline-case
;; If the JOIN keyword followed a CASE expression in the ON clausewhich
;; is printed out in the multiline form, it would become incorrectly
;; indented.
;;
;; XXX Likewise, pgqa-multiline-query is redundant here.
(if (or (null pgqa-multiline-query) (null pgqa-multiline-join))
(user-error "`pgqa-multiline-case' requires both `pgqa-multiline-query' and `pgqa-multiline-join'")))
(if pgqa-clause-newline
(if (null pgqa-multiline-query)
(user-error "`pgqa-clause-newline' requires
`pgqa-multiline-query'")))
(if pgqa-clause-item-newline
(if (null pgqa-clause-newline)
(user-error "`pgqa-clause-item-newline' requires
`pgqa-clause-newline'")))
(if pgqa-clause-keyword-right
(if (null pgqa-multiline-query)
(user-error "`pgqa-clause-keyword-right' requires
`pgqa-multiline-query'")))
)
;; If buffer-pos is maintained, use the following functions to adjust the
;; start and end position of the node.
(defun pgqa-dump-start (node state)
(if (oref state buffer-pos)
;; Temporarily set the slot to plain number.
(oset node region (oref state buffer-pos))))
;; The :gui slot can store either pgqa-gui-node or a list of these. This is a
;; convenience routine so that caller does not have to care.
(defun pgqa-dump-start-gui (node state)
(if (listp node)
(dolist (i node)
(pgqa-dump-start i state))
(pgqa-dump-start node state))
)
(defun pgqa-dump-end (node state)
(if (oref state buffer-pos)
;; Retrieve the start position stored by pgqa-dump-start and replace it
;; with 2-element vector.
(let* ((start (oref node region))
(end (oref state buffer-pos))
(region (vector start end)))
(oset node region region)))
)
;; Counterpart of pgqa-dump-start-gui.
(defun pgqa-dump-end-gui (node state)
(if (listp node)
(dolist (i node)
(pgqa-dump-end i state))
(pgqa-dump-end node state))
)
;; `state' is an instance of `pgqa-deparse-state' class.
;;
;; `indent' determines indentation of the node, relative to (oref node
;; indent).
;;
;; `context' can affect the way node is dumped depending on the surrounding
;; nodes.
(defmethod pgqa-dump ((node pgqa-node) state indent &optional context)
"Turn a node and its children into string."
nil)
;; Wrapper function that either calls pgqa-dump or prints out SQL insertion if
;; the node is contained in it.
(defun pgqa-dump-maybe-insertion (node state indent context)
(let ((insertion)
(insertion-prev)
(insertion-key)
(omit))
(when context
(setq insertion (oref node insertion))
(cl-assert (eq (eieio-object-class-name context)
'pgqa-string-to-query-context))
(setq insertion-prev (oref context last-insertion))
;; Prepare the context for the next node.
(oset context last-insertion insertion)
(when insertion
;; If multiple nodes belong to the same insertion, only print the
;; insertion string once.
(when (or (null insertion-prev)
(null
(string=
(oref insertion-prev key)
(oref insertion key))))
(setq insertion-key (oref insertion key))
;; Insert the insertion. Do it in multiple steps so that line can be
;; broken wherever fill-column is reached.
(pgqa-deparse-string state "'" indent)
(pgqa-deparse-string state "||" indent)
(pgqa-deparse-string state insertion-key indent)
(pgqa-deparse-string state "||" indent)
(pgqa-deparse-string state "'" indent))
;; Do not dump the contained node itself.
(setq omit t))
)
(if (null omit)
(if (eq (eieio-object-class node) 'pgqa-query)
(pgqa-dump-subquery node state indent context)
(pgqa-dump node state indent context)))
)
)
;; Metadata to control deparsing of an SQL query and the contained
;; expressions.
;;
;; Note: the simplest way to control (not) breaking line in front of a
;; subquery is to create a separate instance of this class for the subquery.
;;
;; XXX If adding a new field, check if it's subject to backup / restore by
;; pgqa-dump method of pgqa-operator class. (Is this backup / restore worth
;; separate functions?)
;;
;; TODO Rename to pgqa-dump-state ?
(defclass pgqa-deparse-state ()
(
(indent
:initarg :indent
;; The indentation passed to `pgqa-dump', `pgqa-deparse-string' and
;; subroutines is relative to this.
:documentation "Indentation level of the top level query.")
(indent-top-expr
:initarg :indent-top-expr
:documentation "Indentation, relative to `indent' above, of top level
expression, e.g. the text following top-level keyword. See
`pgqa-deparse-top-keyword' for details.")
(next-column
:initarg :next-column
:documentation "Column at which the following node (or its leading space)
should start.")
(next-space
:initarg :next-space
:documentation "The width of the next space to be printed out.")
(line-empty
:initarg :line-empty
:documentation "Is the current line empty or contains only whitespace?")
(buffer-pos
:initarg :buffer-pos
:documentation "Position in the output buffer at which the next string will start."
)
(result
:initarg :result
:documentation "String to which each node appends its textual
representation.")
)
"State of the deparsing process."
)
;; init-col-src is column (in addition to the indentation) at which the source
;; query starts.
(defun pgqa-init-deparse-state (indent init-col-src line-empty buffer-pos)
"Initialize instance of `pgqa-deparse-state'."
(let ((indent-width (* indent tab-width)))
(make-instance 'pgqa-deparse-state
:indent indent
:indent-top-expr 0
:next-column (+ indent-width init-col-src)
:next-space 0
:line-empty t
:buffer-pos buffer-pos
:result (make-string indent-width 32))))
(defmethod pgqa-deparse-state-get-attrs ((state pgqa-deparse-state))
"Return the slots of `pgqa-deparse-state' as an association list."
(let ((result)
(item))
(dolist (key (object-slots state) result)
(setq item (list key (slot-value state key)))
(push item result))))
(defmethod pgqa-deparse-state-set-attrs ((state pgqa-deparse-state) slots)
"Set slots of `pgqa-deparse-state' to values extracted by
`pgqa-deparse-state-get-attrs'."
(dolist (slot slots)
(set-slot-value state (car slot) (car (cdr slot)))))
;; TODO Check if call is always followed by (oset state next-space 0). If so,
;; incorporate it into the method.
(defmethod pgqa-deparse-newline ((state pgqa-deparse-state) indent)
"Adjust deparse state so that deparsing continues at a new line, properly
indented."
(let* ((indent-loc (+ indent (oref state indent)))
(indent-width (* indent-loc tab-width))
(result (oref state result)))
(setq result (concat result "\n"))
(setq result (concat result
(make-string indent-width 32)))
(oset state result result)
(oset state next-column indent-width)
;; buffer-pos might need to account for the strings added.
(if (oref state buffer-pos)
(oset state buffer-pos (+ (oref state buffer-pos) 1 indent-width)))
(oset state line-empty t))
)
(defmethod pgqa-deparse-space ((state pgqa-deparse-state))
"Write space to deparsing output."
(let ((space (oref state next-space)))
(oset state result
(concat (oref state result)
(make-string space 32)))
(oset state next-column (+ (oref state next-column) space))
;; buffer-pos might need to account for the strings added.
(if (oref state buffer-pos)
(oset state buffer-pos (+ (oref state buffer-pos) space))))
;; Restore the default value of next-space.
(oset state next-space 1))
;; Prepare for insertion of `str', i.e. add line break or space, as
;; needed.
(defmethod pgqa-deparse-string-prepare ((state pgqa-deparse-state) str indent)
(let ((col-incr 0)
(space (oref state next-space)))
(if (> space 0)
(setq col-incr (1+ col-incr)))
(setq col-incr (+ col-incr (string-width str)))
;; Zero space currently can't be broken.
;;
;; TODO Consider if there are special cases not to subject to this
;; restriction, and maybe introduce custom variable that allows breaking
;; even the zero space.
(when (and fill-column (> space 0)
(> (+ (oref state next-column) col-incr) fill-column))
(pgqa-deparse-newline state indent)
;; No space (in addition to indentation) after newline.
(oset state next-space 0))
(pgqa-deparse-space state))
)
(defmethod pgqa-deparse-string ((state pgqa-deparse-state) str indent)
"Write arbitrary string to deparsing output."
(pgqa-deparse-string-prepare state str indent)
;; In some cases we stick the next string to the current one w/o space
;; (which currently makes newline impossible - see
;; pgqa-deparse-string-prepare).
(if (or
(string= str "(") (string= str "["))
(oset state next-space 0))
(oset state result (concat (oref state result) str))
(let ((str-width (string-width str)))
(oset state next-column (+ (oref state next-column) str-width))
;; buffer-pos might need to account for the strings added.
(if (oref state buffer-pos)
(oset state buffer-pos (+ (oref state buffer-pos) str-width))))
;; clear line-empty if the string contains non-whitespace character.
(if (string-match "\\S-" str)
(oset state line-empty nil)))
;; Top-level keyword might deserve special attention, e.g. adding tabs between
;; itself and the following expression.
;;
;; `first' indicates that this is the first top-level keyword of the whole
;; query.
(defmethod pgqa-deparse-top-keyword ((state pgqa-deparse-state) keyword first)
"Dump top-level keyword (SELECT, INSERT, FROM, WHERE, etc.)"
(let ((first-offset 0)
(nspaces))
;; For the structured output, all top-level keywords except for the first
;; one need line break.
(when (and pgqa-multiline-query (null first))
(pgqa-deparse-newline state 0)
;; No space in front of the keyword, even if the keyword does not cause
;; line break itself.
(oset state next-space 0))
;; The first line of the deparsed query may be indented more than the rest
;; (see indent-estimate in pgqa-deparse).
(if (and pgqa-multiline-query first)
(setq first-offset
(- (oref state next-column)
(* (oref state indent) tab-width))))
(if (and pgqa-multiline-query
;; Make sure the clause is correctly indented.
;;
;; Right alignment of the clause keyword is also a reason to
;; compute the space, even though the clause might end up on a
;; new line. In such a case we'll simply put the space left from
;; the keyword.
(or
(null pgqa-clause-newline)
pgqa-clause-keyword-right))
(let* ((indent-top-expr (oref state indent-top-expr)))
(setq nspaces (- (* indent-top-expr tab-width) (string-width keyword)))
;; Anything wrong about computation of indent-top-expr?
(if (and (null pgqa-clause-newline) (< nspaces 1))
(error "indent-top-expr is too low"))
;; No extra space if the next text would exceed fill-column.
(if (and
fill-column
(>= (+ (oref state next-column) nspaces) fill-column))
(setq nspaces 1))
;; Shorten the space so that the expression (most likely column
;; list) starts at the same position as the other expressions
;; (e.g. table list).
(when (> first-offset 0)
(setq nspaces (- nspaces first-offset))
;; Make sure at least one space is left.
(if (< nspaces 1)
(setq nspaces 1)))))
;; If the clause keyword should be right-aligned, put the space in front
;; of it. but leave 1 to be written between the keyword and the actual
;; clause expression.
(when (and nspaces (> nspaces 1) pgqa-clause-keyword-right)
;; If the clause should appear on the same line as the keyword, retain
;; one space to separate them. If the clause starts at a new line, use
;; the whole nspaces for the right alignment.
(let ((i (if pgqa-clause-newline 0 1)))
(while (< i nspaces)
(pgqa-deparse-space state)
(setq nspaces (1- nspaces)))))
(pgqa-deparse-string state keyword
(if pgqa-multiline-query 1 0))
;; Separate the clause from the keyword.
(if nspaces
(oset state next-space nspaces))
(if pgqa-clause-newline
;; Avoid the single space that pgqa-dump of pgqa-operator class puts in
;; front of operators.
(oset state next-space 0)))
)
;; In this subclass the function does not need the `indent' argument - the
;; base indentation is controlled by (oref state indent). (EIEIO does not
;; allow omitting the argument altogether.)
(defmethod pgqa-dump ((node pgqa-query) state indent context)
"Turn query into a string."
(pgqa-dump-start node state)
;; For mutiline output, compute the first column for expressions.
(if pgqa-multiline-query
(if pgqa-clause-newline
;; No need to separate the keyword from the clause using a space, so
;; no need to adjust indent-top-expr.
(oset state indent-top-expr 1)
;; The additional space can affect indent-top-expr.
(progn
;; TODO Put the following into a separate function
(let ((top-clauses)
(max-width 0)
(indent-expr)
(kind (oref node kind)))
(if (oref node target-expr)
(push "SELECT" top-clauses))
(if (oref node target-table)
(if (string= kind "UPDATE")
(push "UPDATE" top-clauses)
(if (string= kind "INSERT")
(push "INSERT INTO" top-clauses))))
(if (oref node from-expr)
(let ((fe (oref node from-expr)))
(if (> (length (oref fe from-list)) 0)
(push "FROM" top-clauses))
(if (slot-boundp fe 'qual)
(push "WHERE" top-clauses))
))
(if (oref node group-by)
(push "GROUP BY" top-clauses))
(if (oref node having)
(push "HAVING" top-clauses))
(if (oref node order-by)
(push "SORT BY" top-clauses))
;; Find out the maximum length.
(dolist (i top-clauses)
(let ((width (string-width i)))
(if (> width max-width)
(setq max-width width))))
;; At least one space must follow.
(setq max-width (1+ max-width))
;; Round up to the nearest multiple of tab-width.
(setq max-width
(+ max-width
(- tab-width (% max-width tab-width))))
(oset state indent-top-expr (/ max-width tab-width))))
)
)
(let ((indent-clause))
(if pgqa-clause-newline
(setq indent-clause 1)
;; Extra tab might have been added in front of the clause (to ensure
;; that all clauses of the query start at the same position), so all
;; lines of the clause must start at that position.
(setq indent-clause (oref state indent-top-expr)))
(if (string= (oref node kind) "SELECT")
(let ((te (oref node target-expr)))
(pgqa-deparse-top-keyword state "SELECT" t)
;; Enforce line break if necessary.
;;
;; TODO The same for ORDER BY, WINDOW, LIMIT, etc.
(if pgqa-clause-newline
(pgqa-deparse-newline state indent-clause))
(pgqa-dump te state indent-clause context)))
(if (string= (oref node kind) "UPDATE")
(let ((tt (oref node target-table))
(te (oref node target-expr)))
(pgqa-deparse-top-keyword state "UPDATE" t)
(if pgqa-clause-newline
(pgqa-deparse-newline state indent-clause))
(pgqa-dump tt state indent-clause context)
(pgqa-deparse-top-keyword state "SET" nil)
(if pgqa-clause-newline
(pgqa-deparse-newline state indent-clause))
(pgqa-dump te state indent-clause context)))
(if (string= (oref node kind) "INSERT")
(let ((tt (oref node target-table))
(te (oref node target-expr))
(ic (oref node insert-cols)))
(pgqa-deparse-top-keyword state "INSERT INTO" t)
(if pgqa-clause-newline
(pgqa-deparse-newline state indent-clause))
(pgqa-dump tt state indent-clause context)
(when ic
(oset state next-space 0)
(pgqa-deparse-string state "(" indent)
(pgqa-dump ic state indent-clause context)
(oset state next-space 0)
(pgqa-deparse-string state ")" indent))
(if te
(pgqa-deparse-top-keyword state "SELECT" nil))
(if pgqa-clause-newline
(pgqa-deparse-newline state indent-clause))
(pgqa-dump te state indent-clause context)
))
(if (oref node from-expr)
(let ((from-expr (oref node from-expr)))
;; Update may or may not have FROM clause.
(pgqa-dump from-expr state 0 context)))
(if (oref node group-by)
(pgqa-dump (oref node group-by) state 0 context))
(if (oref node having)
(pgqa-dump (oref node having) state 0 context))
(if (oref node order-by)
(pgqa-dump (oref node order-by) state 0 context))
)
(pgqa-dump-end node state))
;; Find out if from-list-entry needs to be parenthesized.
;;
;; join-rhs is t if the node is join RHS, nil if its join LHS or
;; an item of the FROM-list.
(defun pgqa-from-list-entry-needs-parens (node join-rhs)
(if (eq (eieio-object-class node) 'pgqa-from-list-entry)
(let ((is-join (= (length (oref node args)) 2))
(is-query (string= (oref node kind) "query")))
;; Query needs the parentheses always, join only if it's on the right side
;; of another join or if it has an alias.
(or is-query (and is-join (or join-rhs (slot-boundp node 'alias))))))
)
;; Return the FROM-list subquery or nil if the entry is something else (table,
;; join, etc.).
(defun pgqa-get-from-list-suquery (fe)
(if (and (eq (eieio-object-class fe) 'pgqa-from-list-entry)
(string= (oref fe kind) "query"))
(car (oref fe args)))
)
(defmethod pgqa-dump ((node pgqa-from-expr) state indent context)
(pgqa-dump-start node state)
(let ((from-list (oref node from-list))
(indent-clause))
;; See the related comment in pgqa-dump method of pgqa-query class.
(if pgqa-clause-newline
(setq indent-clause (1+ indent))
(setq indent-clause (oref state indent-top-expr)))
;; INSERT, UPDATE or DELETE statement can have the list empty.
(if (> (length from-list) 0)
(progn
(pgqa-deparse-top-keyword state "FROM" nil)
;; (if pgqa-clause-newline
;; (pgqa-deparse-newline state indent-clause))
(let* ((i 0)
(fe-query)
(newline)
(parens)
(is-join))
(dolist (item from-list)
(if (> i 0)
(progn
(oset state next-space 0)
(pgqa-deparse-string state "," indent-clause)
;; In general, comma should be followed by a space. As for
;; special cases, we'll set it to zero explicitly below.
(if (null pgqa-join-newline)
(oset state next-space 1))))
(setq parens (pgqa-from-list-entry-needs-parens item nil))
(setq is-join (= (length (oref item args)) 2))
(setq fe-query (pgqa-get-from-list-suquery item))
;; XXX Can we do anything better than breaking the line if
;; parens is t but pgqa-clause-item-newline is nil?
;;
;; TODO Consider newline even if pgqa-join-newline is nil but
;; the next entry is a join that starts with left parenthesis
;; (i.e. the join needs the parentheses itself, or its left-most
;; argument does).
(setq newline
(or
(and (= i 0) pgqa-clause-newline)
(and
(> i 0)
(or (and parens pgqa-multiline-query) pgqa-clause-item-newline
(and is-join pgqa-join-newline))
(null (oref state line-empty)))))
(if newline
(pgqa-deparse-newline state indent-clause))
;; Set next-space to 0 to avoid unnecessary space, or even
;; newline in the case of a join.
(if (> (oref state next-space) 0)
(if (or parens is-join pgqa-clause-item-newline)
(progn
;; Only apply the space if non-empty line continues
;; here.
(if (null (oref state line-empty))
(pgqa-deparse-space state))
(oset state next-space 0))
)
)
(if parens
(pgqa-deparse-string state "(" indent))
(if fe-query
(pgqa-dump-subquery (car (oref item args))
state indent-clause context)
(pgqa-dump-maybe-insertion item state indent-clause context))
(if parens
(progn
(oset state next-space 0)
(pgqa-deparse-string state ")" indent-clause)))
(if (slot-boundp item 'alias)
(pgqa-dump (oref item alias) state indent-clause context))
(setq i (1+ i)))
)
)
)
)
(if (slot-boundp node 'qual)
(let ((indent-clause))
;; Like above. XXX Should the whole body of the function be wrapped in
;; an extra "let" construct, which initializes the variable only
;; once?)
(if pgqa-clause-newline
(setq indent-clause (1+ indent))
(setq indent-clause (oref state indent-top-expr)))
;; `space' should be up-to-date as the FROM clause is mandatory.
(pgqa-deparse-top-keyword state "WHERE" nil)
(if pgqa-clause-newline
(pgqa-deparse-newline state indent-clause))
(pgqa-dump (oref node qual) state indent-clause context)))
(pgqa-dump-end node state))
(defmethod pgqa-dump ((node pgqa-from-list-entry) state indent context)
"Print out FROM list entry (table, join, subquery, etc.)."
(pgqa-dump-start node state)
(let* ((args (oref node args))
(nargs (length args))
(is-join (= nargs 2))
(arg (car args))
(fe-query)
(parens)
(newline)
;; If this happens to be a join nested in another one, that upper
;; join might use next-space to indicate that it already took care of
;; the newline.
(no-space (and is-join (= (oref state next-space) 0))))
(cl-assert (or (= nargs 1) (= nargs 2)))
(setq parens (pgqa-from-list-entry-needs-parens arg nil))
(if (null is-join)
(progn
;; If the node is query, it'll be handled by upper node, which is
;; responsible for parentheses and line breaks.
(setq fe-query (pgqa-get-from-list-suquery node))
(if (null fe-query)
(pgqa-dump arg state indent context)))
(progn
;; arg is LHS of the join.
;;
;; XXX Can we do anything smarter than breaking the line if parens is
;; t but pgqa-join-newline is nil?
(setq newline
(and
pgqa-multiline-query
(or parens pgqa-join-newline)
;; Only break the line if it hasn't just happened for any
;; reason.
(null (oref state line-empty))
;; The purpose of no-space is explained above.
(null no-space)))
(if newline
(progn
;; TODO Shouldn't pgqa-deparse-newline set next-space to zero?
(pgqa-deparse-newline state indent)
(oset state next-space 0)))
(if parens
(progn
;; There should be no space in front of the next character, but
;; we also set next-space to zero to indicate that nested entry
;; should not be preceded by a newline.
(oset state next-space 0)
(pgqa-deparse-string state "(" indent)))
(setq fe-query (pgqa-get-from-list-suquery arg))
(if fe-query
(pgqa-dump-subquery fe-query state indent context)
(pgqa-dump arg state indent context))
(if parens
(progn
(oset state next-space 0)
(pgqa-deparse-string state ")" indent)))
;; Print the alias separate so that it does not appear inside the
;; parentheses.
(if (slot-boundp arg 'alias)
(pgqa-dump (oref arg alias) state indent context))
)
)
(if is-join
(progn
(if pgqa-multiline-join
(progn
(oset state next-space 0)
(pgqa-deparse-newline state indent)))
(let ((kind (oref node kind)))
(if kind
(pgqa-deparse-string state (upcase kind) indent)))
(pgqa-deparse-string state "JOIN" indent)
;; The right side of a join might require parentheses.
(let* ((arg (nth 1 args)))
(setq parens (pgqa-from-list-entry-needs-parens arg t))
;; XXX Can we do anything smarter than breaking the line if parens
;; is t but pgqa-join-newline is nil?
(setq newline
(and pgqa-multiline-query
(or parens pgqa-join-newline)
;; Only break the line if it hasn't just happened for
;; any reason.
(null (oref state line-empty))))
(if newline
(progn
(oset state next-space 0)
(pgqa-deparse-newline state indent)))
(if parens
(pgqa-deparse-string state "(" indent))
(setq fe-query (pgqa-get-from-list-suquery arg))
(if fe-query
(pgqa-dump-subquery fe-query state indent context)
(pgqa-dump arg state indent context))
(if parens
(progn
(oset state next-space 0)
(pgqa-deparse-string state ")" indent)))
;; pgqa-dump-subquery couldn't print the alias because thus
;; it'd appear inside the parentheses.
(if (slot-boundp arg 'alias)
(pgqa-dump (oref arg alias) state indent context)))
(pgqa-deparse-string state "ON" indent)
(pgqa-dump (oref node qual) state
(if pgqa-multiline-join (1+ indent) indent) context)))
)
(pgqa-dump-end node state))
;; Dump query in the FROM list or in an expression.
;;
;; TODO Consider custom variable that controls whether parentheses are on the
;; same lines the query starts and ends respectively.
(defun pgqa-dump-subquery (query state indent context)
(let ((state-loc state))
(if pgqa-multiline-query
;; Use a separate state to print out query.
;;
;; init-col-src of 1 stands for the opening parenthesis.
(progn
(setq state-loc (pgqa-init-deparse-state
(+ (oref state indent) indent) 1 t
(oref state buffer-pos)))
(oset state-loc next-column (oref state next-column))
(oset state-loc result (oref state result))))
(pgqa-dump query state-loc 0 context)
(oset state result (oref state-loc result))
(if pgqa-multiline-query
(progn
(oset state next-column (oref state-loc next-column))
(oset state buffer-pos (oref state-loc buffer-pos)))))
(oset state next-space 0)
)
(defmethod pgqa-dump ((node pgqa-from-list-entry-alias) state indent context)
"Turn alias into a string."
(if pgqa-print-as
(pgqa-deparse-string state "AS" indent))
(pgqa-dump-start node state)
(pgqa-dump (oref node name) state indent context)
;; Print out argument list if there is some.
(when (slot-boundp node 'cols)
;; No space in front of the left parenthesis.
(oset state next-space 0)
(pgqa-deparse-string state "(" indent)
(pgqa-dump (oref node cols) state indent context)
;; No space in front of the right parenthesis.
(oset state next-space 0)
(pgqa-deparse-string state ")" indent))
(pgqa-dump-end node state))
(defmethod pgqa-dump ((node pgqa-top-clause) state indent context)
(pgqa-dump-start node state)
(let* ((indent-clause)
(cn (eieio-object-class-name node))
(kwd)
(expr (oref node expr)))
(setq kwd
(if (eq cn 'pgqa-group-clause)
"GROUP BY"
(if (eq cn 'pgqa-having-clause)
"HAVING"
(if (eq cn 'pgqa-sort-clause)
"ORDER BY"
(error
(format "Unrecognized top level expression class %s." cn))))))
(pgqa-deparse-top-keyword state kwd nil)
;; See the related comment in pgqa-dump method of pgqa-query class.
(if pgqa-clause-newline
(setq indent-clause (1+ indent))
(setq indent-clause (oref state indent-top-expr)))
(if pgqa-clause-newline
(pgqa-deparse-newline state indent-clause))
(pgqa-dump expr state indent-clause context))
(pgqa-dump-end node state))
(defmethod pgqa-dump ((node pgqa-func-call) state indent context)
"Print out function call"
;; Dump the function name and use pgqa-dump-start / pgqa-dump-end to mark
;; set the region of the operator string. This is needed so we can
;; eventually assign face to the string.
(pgqa-dump-start (nth 0 (oref node gui)) state)
(pgqa-dump (oref node name) state indent context)
(pgqa-dump-end (nth 0 (oref node gui)) state)
;; No space between function name and the parenthesis.
(oset state next-space 0)
;; Adjust the GUI node of the left parenthesis.
(pgqa-dump-start (nth 1 (oref node gui)) state)
(pgqa-deparse-string state "(" indent)
(pgqa-dump-end (nth 1 (oref node gui)) state)
(let ((args (oref node args)))
(if (> (length args) 0)
(pgqa-dump args state indent context)))
;; Likewise, no space after.
(oset state next-space 0)
;; Adjust the GUI node of the right parenthesis.
(pgqa-dump-start (nth 2 (oref node gui)) state)
(pgqa-deparse-string state ")" indent)
(pgqa-dump-end (nth 2 (oref node gui)) state)
)
(defmethod pgqa-dump ((node pgqa-string) state indent context)
"Dump a string constant."
(pgqa-dump-start node state)
(let ((str (oref node value)))
;; If we're converting query to SQL string, string constants must be
;; quoted.
(if (and context
(eq (eieio-object-class-name context)
'pgqa-string-to-query-context))
(setq str (format "'%s'" str)))
(pgqa-deparse-string state str indent))
(pgqa-dump-end node state))
(defmethod pgqa-dump ((node pgqa-number) state indent context)
"Turn number into a string."
(pgqa-dump-start node state)
(let ((str (oref node value)))
(pgqa-deparse-string state str indent))
(pgqa-dump-end node state))
(defmethod pgqa-dump ((node pgqa-obj) state indent context)
"Turn an SQL object into a string."
(pgqa-dump-start node state)
(let ((str (mapconcat 'format (oref node args) ".")))
(pgqa-deparse-string state str indent))
(pgqa-dump-end node state))
(defmethod pgqa-dump ((node pgqa-data-type) state indent context)
"Turn data type into a string."
(pgqa-dump-start node state)
(dolist (i (oref node args))
(pgqa-dump i state indent context))
(pgqa-dump-end node state))
(defmethod pgqa-dump ((node pgqa-case) state indent context)
"Print out the CASE expression."
(pgqa-dump-start node state)
;; The multi-line output should start exactly at the indentation which is
;; determined by the indent argument, so new line is needed.
(when (and pgqa-multiline-case (null (oref state line-empty)))
(pgqa-deparse-newline state indent)
(oset state next-space 0))
(pgqa-deparse-string state "CASE" indent)
(let ((indent-2 indent))
(if pgqa-multiline-case
(setq indent-2 (1+ indent-2)))
(if (oref node arg)
;; Even the argument deserves extra indentation, in case it spans
;; multiple lines.
(pgqa-dump (oref node arg) state indent-2 context))
(dolist (branch (oref node branches))
(when pgqa-multiline-case
(pgqa-deparse-newline state indent-2)
(oset state next-space 0))
(pgqa-dump branch state indent-2 context))
(when (slot-boundp node 'else)
(when pgqa-multiline-case
(pgqa-deparse-newline state indent-2)
(oset state next-space 0))
(pgqa-deparse-string state "ELSE" indent-2)
(pgqa-dump (oref node else) state indent-2 context))
)
(when pgqa-multiline-case
(pgqa-deparse-newline state indent)
(oset state next-space 0))
(pgqa-deparse-string state "END" indent)
(pgqa-dump-end node state))
(defmethod pgqa-dump ((node pgqa-case-branch) state indent context)
"Print out a single branch (WHEN ... THEN ...) of the CASE expression."
(pgqa-dump-start node state)
(let* ((args (oref node args))
(when-expr (car args))
(then-expr (car (cdr args)))
(indent-2 indent))
(pgqa-deparse-string state "WHEN" indent)
;; The arguments should get extra indentation, if they span multiple
;; lines. (Not sure it looks nice if pgqa-multiline-case is sufficient to
;; cause this extra indentation.)
(if pgqa-multiline-case-branch
(setq indent-2 (1+ indent-2)))
(pgqa-dump when-expr state indent-2 context)
(when pgqa-multiline-case-branch
(pgqa-deparse-newline state indent)
(oset state next-space 0))
(pgqa-deparse-string state "THEN" indent)
(pgqa-dump then-expr state indent-2 context))
;; If the WHEN and THEN clauses are separated by a newline, the whole CASE
;; expression looks better if an extra line break is added in front of the
;; next branch (or in front of the ELSE clause).
(if pgqa-multiline-case-branch
(pgqa-deparse-newline state 0))
(pgqa-dump-end node state))
(defun pgqa-child-op-needs-parens (node arg)
"Find out if argument of an operator node should be parenthesized."
(if
(or
;; Query as an argument should always be parenthesized.
(eq (eieio-object-class arg) 'pgqa-query)
;; Sublink can have either query or an (array) expression as an
;; argument, both of which should always be parenthesized.
(eq (eieio-object-class node) 'pgqa-sublink))
t
(let ((prec (oref node prec))
(prec-child
(if (object-of-class-p arg pgqa-operator)
(oref arg prec))))
(and prec prec-child (> prec prec-child))))
)
(defun pgqa-is-multiline-operator (node)
"Should the argument be printed in structured way?"
(if (and pgqa-multiline-operator
(or
(object-of-class-p node 'pgqa-operator)
(and
pgqa-multiline-case
(object-of-class-p node 'pgqa-case))))
;; List is not a multi-line operator as such, although its arguments
;; can be.
(null (object-of-class-p node 'pgqa-node-list))
)
)
;; indent relates to the operator, not argument.
(defun pgqa-indent-operator-first-argument (state indent arg-idx)
"Prepare position for the first argument of a multiline operator."
(let* ((s (oref state result))
(i (1- (length s))))
(if
;; No duplicate newline if we already have one.
(and pgqa-clause-newline (= arg-idx 0) (oref state line-empty))
(let ((indent-extra
(-
;; indent argument of the function is relative to (oref state
;; indent), so compute "absolute value".
(+ (oref state indent) indent)
(/ (oref state next-column) tab-width)))
(indent-extra-spaces))
;; indent is for the operator, so add 1 more level for the argument.
(setq indent-extra (1+ indent-extra))
(setq indent-extra-spaces (* indent-extra tab-width))
(oset state result
(concat (oref state result)
(make-string indent-extra-spaces 32)))
(if (oref state buffer-pos)
(oset state buffer-pos (+ (oref state buffer-pos)
indent-extra-spaces))))
(progn
(pgqa-deparse-newline state (1+ indent))
(oset state next-space 0))))
)
(defmethod pgqa-dump ((node pgqa-operator) state indent context)
"Turn operator expression into a string."
(pgqa-dump-start node state)
(let* ((args (oref node args))
(nargs (length args))
(op (oref node op))
(is-list (object-of-class-p node 'pgqa-node-list))
(is-unary
(null
(or (cdr args) is-list)))
(is-cast (string= op "::"))
(i 0)
(multiline
(and
pgqa-multiline-operator
(pgqa-is-multiline-operator node)))
(arg-multiline-prev))
(dolist (arg args)
(let* ((parens (pgqa-child-op-needs-parens node arg))
(state-backup)
(arg-is-operator (object-of-class-p arg 'pgqa-operator))
(arg-is-list (object-of-class-p arg 'pgqa-node-list))
(arg-is-te (eq (eieio-object-class arg) 'pgqa-target-entry))
;; FROM list entry?
(arg-is-fe (eq (eieio-object-class arg) 'pgqa-from-list-entry))
(arg-is-query (eq (eieio-object-class arg) 'pgqa-query))
(arg-multiline)
(indent-arg indent)
(gui (oref node gui)))
(if arg-is-te
(setq arg-multiline (pgqa-is-multiline-operator (oref arg expr)))
(setq arg-multiline (pgqa-is-multiline-operator arg)))
(if (or (and is-unary (null (oref node postfix))) (> i 0))
(let ((omit-space))
;; Never put space in front of comma or cast operator.
(setq omit-space (or is-list is-cast))
;; Should each arg start at a new line?
(when multiline
(pgqa-deparse-newline state indent)
(setq omit-space t))
(if omit-space
(oset state next-space 0))
;; BETWEEN-AND operator has 2 keywords, and "gui" is a 2-element
;; list containing one node per keyword.
(if (equal op "BETWEEN")
(if (= i 1)
(setq gui (car gui))
(when (= i 2)
(setq op "AND")
(if gui
(setq gui (car (cdr gui))))
)
)
)
;; Use pgqa-dump-start / pgqa-dump-end to mark set the region of
;; the operator string. This is needed so we can eventually
;; assign face to the string.
(if gui
(pgqa-dump-start gui state))
(pgqa-deparse-string state op indent)
;; Cast operator (::) is special in that it should not be
;; separated from the target type by space.
(if is-cast
(oset state next-space 0))
(if gui
(pgqa-dump-end gui state)))
)
;; Ensure correct initial position for the argument output in case the
;; operator spans multiple lines.
(if multiline
(if (or
;; "(" should appear on a new line, indented as the argument
;; would be if there were no parentheses. (The argument itself
;; will eventually be given extra indentation.)
parens
(and
;; If the arg is also an operator, it'll take care of the
;; initial line preparation itself.
(null arg-is-operator)
;; If the current operator (i.e. not the argument) is unary
;; prefix (not enclosed in parentheses) - it looks better if
;; both operator and argument end up on the same
;; line. Again, if the argument of the unary operator is
;; operator itself (which includes parentheses), it'll take
;; care of the preparation itself.
(or (> (length args) 1) (oref node postfix))
)
)
(pgqa-indent-operator-first-argument state indent i)
)
(when
(or
(and is-list
;; Multi-line argument takes care of the initial line
;; preparation itself.
(null arg-multiline)
(or
;; If an "ordinary" expression follows a multi-line
;; operator within comma operator (e.g. SELECT list),
;; break the line so that the multi-line operator does not
;; share even a single line with the current argument.
;;
;; TODO Consider a custom variable to switch this behavior
;; on / off.
arg-multiline-prev
;; Definitely break the line if user requires each target
;; list / from list entry to begin on a new line.
;;
;; Do nothing for i = 0 because pgqa-clause-item-newline
;; requires pgqa-clause-newline to be set, which takes
;; care of the first entry. Only take action if the comma
;; is a target list of FROM list (i.e. do not affect
;; things like function argument list).
(and pgqa-clause-item-newline (> i 0)
(or arg-is-te arg-is-fe))))
;; Another reason to break the line is a query in an expression
;; (e.g. IN). If we didn't break the line here, the first line
;; (typically SELECT) whould be much more indented than the
;; following lines.
(and pgqa-multiline-query arg-is-query))
(pgqa-deparse-newline state indent)
(oset state next-space 0))
)
(when parens
;; In case we're not at the start of a new line, so make sure that
;; there's no space between the sublink keyword and the left
;; parenthesis. XXX Consider customization variable that allows such
;; a space.
(if (eq (eieio-object-class node) 'pgqa-sublink)
(oset state next-space 0))
(pgqa-deparse-string state "(" indent)
;; No space, whatever follows "(".
(oset state next-space 0))
;; Comma needs special treatment because it doesn't look nice if it's
;; the first character on a line.
;;
;; Backup the slots but keep the instance so that callers still see
;; our changes.
(setq state-backup (pgqa-deparse-state-get-attrs state))
;; Serialize the argument now, giving it additional indentation if
;; user wants the output structured.
(let ((indent-extra 0))
(when multiline
(setq indent-extra (1+ indent-extra))
;; The extra indentation due to parentheses, mentioned above. It
;; only applies to operators, not to subqueries.
(if (and parens (null arg-is-query))
(setq indent-extra (1+ indent-extra))))
(setq indent-arg (+ indent indent-extra))
;; Operator can be contained in an SQL string insertion.
(pgqa-dump-maybe-insertion arg state indent-arg context))
(when
;; If the argument has reached fill-column, line should have
;; broken in front of the argument. So restore the previous state
;; and dump the argument again, with fill-column temporarily
;; decreased by one. That should make the argument appear on the
;; new line too.
(and
(>= (oref state next-column) fill-column)
(< i (1- nargs)))
(pgqa-deparse-state-set-attrs state state-backup)
;; TODO Loop until the line is broken correctly, but don't let
;; fill-column reach value that lets little or no space on the
;; line. But only try once if the related custom variable(s) allow
;; for line break between opening paren and the following character
;; or closing paren and the preceding character.
(let ((fill-column (1- fill-column)))
(pgqa-dump-maybe-insertion arg state indent-arg context))
)
(when parens
;; The closing parenthesis should be on a separate line, like the
;; opening one.
(when
(and multiline
;; Row expression is not considered a multi-line operator,
;; so it looks better if the ")" is stuck to it.
;;
;; TODO Verify the behavior when the last expression of the
;; row is a multi-line operator.
(or (null arg-is-list) (= (length (oref arg args)) 1))
;; Subquery in an operator should have both opening and
;; closing parenthesis attached tightly to it, just like it
;; works for subquery in the FROM list.
(null arg-is-query))
(pgqa-deparse-newline state (1+ indent)))
;; Never space in front of ")".
(oset state next-space 0)
(pgqa-deparse-string state ")" indent))
(when (and is-unary (oref node postfix))
;; TODO This part appears above for binary and unary prefix
;; operators. Move it into a new function (pgqa-deparse-op-string?)
(if (oref node gui)
(pgqa-dump-start-gui (oref node gui) state))
(pgqa-deparse-string state op indent)
(if (oref node gui)
(pgqa-dump-end-gui (oref node gui) state)))
(setq i (1+ i))
(setq arg-multiline-prev arg-multiline))
)
)
(pgqa-dump-end node state))
(defmethod pgqa-dump ((node pgqa-target-entry) state indent context)
"Turn target list entry into a string."
(pgqa-dump-start node state)
(pgqa-dump (oref node expr) state indent context)
(when (slot-boundp node 'alias)
(if pgqa-print-as
(pgqa-deparse-string state "AS" indent))
(pgqa-dump (oref node alias) state indent context))
(pgqa-dump-end node state))
(defmethod pgqa-dump ((node pgqa-alias) state indent context)
"Turn target list entry alias into a string."
(pgqa-dump-start node state)
(pgqa-deparse-string state (oref node name) indent)
(pgqa-dump-end node state))
(defmethod pgqa-dump ((node pgqa-alias-arg) state indent context)
"Turn an argument of a target list entry alias into a string."
(pgqa-dump-start node state)
(pgqa-deparse-string state (oref node var) indent)
(if (slot-boundp node 'datatype)
(pgqa-dump (oref node datatype) state indent context))
(pgqa-dump-end node state))
(provide 'pgqa-dump)
pgqa-0.1/pgqa-dump-raw.el 0000644 0001751 0000144 00000025127 13376770703 013642 0 ustar ah users ;; Copyright (C) 2016 Antonin Houska
;;
;; This file is part of PGQA.
;;
;; PGQA 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.
;; PGQA 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 qalong
;; with PGQA. If not, see .
;; This module prints the query tree in machine readable format.
(eval-when-compile
(require 'subr-x))
(require 'pgqa-node)
(defcustom pgqa-query-tree-print-region t
"If non-nil, the output of `pgqa-dump-raw' contains node region info.")
;; Metadata to control printing out the internal representation of a query
;; tree node.
(defclass pgqa-dump-raw-state ()
(
(node-start
:initarg :node-start
:documentation
"Function that returns the initial part of the node.
The funcion receives the node and indentation level as the first and second
arguments respectively.")
(node-end
:initarg :node-end
:documentation
"Function that returns the final part of the node.
The funcion receives the node and indentation level as the first and second
arguments respectively.")
(result
:initarg :result
:documentation "String to which each node appends its textual
representation.")
)
)
(defun pgqa-dump-raw-append (state str)
"Append STR to the current result."
(oset state result (format "%s%s" (oref state result) str)))
;; Convenience macro to call `node-start' or `node-end' function of the
;; `state' and update the `result' accordingly.
(defmacro pgqa-dump-raw-node (kind node state indent)
`(let ((func (oref state ,kind))
(orig (oref ,state result)))
(oset ,state result
(string-join
(list
orig
(funcall func ,node ,indent))))))
(defun pgqa-node-to-lisp-start (node indent)
"Turn the query tree node into the initial part of lisp-like expression."
(let ((region "")
(node-name)
(indent-str (pgqa-lisp-indent-string indent)))
(setq node-name (symbol-name (eieio-object-class-name node)))
;; The class name w/o the leading "pgqa-" part seems to be an useful node
;; name.
(setq node-name (substring node-name (length "pgqa-") (length node-name)))
(if pgqa-query-tree-print-region
(setq region (format " %s" (oref node region))))
(format "%s(%s%s\n" indent-str node-name region)))
(defun pgqa-node-to-lisp-end (node indent)
"Turn the query tree node slot into the final part of lisp-like expression."
(format "%s)\n" (pgqa-lisp-indent-string (1+ indent))))
;; Subroutine for the macros below.
(defun pgqa-slot-to-lisp-common (node state slot-name indent)
(oset state result
(format "%s%s:%s"
(oref state result)
(pgqa-lisp-indent-string indent)
slot-name))
)
(defmacro pgqa-simple-slot-to-lisp (node state slot-name indent)
"Turn a simple slot of the query tree node into a string."
`(progn
(pgqa-slot-to-lisp-common
,node
,state
(quote ,slot-name)
,indent)
(pgqa-dump-raw-append ,state
(format " %s\n"
(oref ,node ,slot-name)))
)
)
;; Like above but the slot is a node itself.
(defmacro pgqa-node-slot-to-lisp (node state slot-name indent)
"Turn a node slot of the query tree node into a string."
`(progn
(pgqa-slot-to-lisp-common
,node
,state
(format "%s%s" (quote ,slot-name) "\n")
,indent)
(pgqa-dump-raw (oref ,node ,slot-name) ,state (1+ ,indent)))
)
;; Like above but the slot is a list.
(defmacro pgqa-list-slot-to-lisp (node state slot-name indent)
"Turn a list slot of the query tree node into a string."
`(progn
(pgqa-slot-to-lisp-common
,node
,state
(format "%s%s" (quote ,slot-name) "\n")
,indent)
(pgqa-dump-raw-append ,state
(format "%s(\n"
(pgqa-lisp-indent-string (1+ ,indent))))
(dolist (i (oref ,node ,slot-name))
(pgqa-dump-raw i state (+ ,indent 2)))
(pgqa-dump-raw-append ,state
(format "%s)\n"
(pgqa-lisp-indent-string (+ ,indent 2))))
)
)
;; Create string for given indentation level, for the lisp output.
(defun pgqa-lisp-indent-string (indent)
(make-string (* indent 2) 32))
;; `state' is an instance of `pgqa-dump-raw-state' class.
;;
;; `indent' is the number of ancestor nodes.
(defmethod pgqa-dump-raw ((node pgqa-node) state indent)
"Print out the internal representation of a query node."
(pgqa-dump-raw-node node-start node state indent)
(pgqa-dump-raw-node node-end node state indent))
(defmethod pgqa-dump-raw ((node pgqa-query) state indent)
"Print out the internal representation of a query."
(pgqa-dump-raw-node node-start node state indent)
(pgqa-node-slot-to-lisp node state target-expr (1+ indent))
(if (oref node from-expr)
(pgqa-node-slot-to-lisp node state from-expr (1+ indent)))
(if (oref node group-by)
(pgqa-node-slot-to-lisp node state group-by (1+ indent)))
(if (oref node having)
(pgqa-node-slot-to-lisp node state having (1+ indent)))
(if (oref node order-by)
(pgqa-node-slot-to-lisp node state order-by (1+ indent)))
(if (oref node target-table)
(pgqa-node-slot-to-lisp node state target-table (1+ indent)))
(if (oref node insert-cols)
(pgqa-node-slot-to-lisp node state insert-cols (1+ indent)))
(pgqa-dump-raw-node node-end node state indent))
(defmethod pgqa-dump-raw ((node pgqa-from-expr) state indent)
(pgqa-dump-raw-node node-start node state indent)
(if (slot-boundp node 'from-list)
(pgqa-list-slot-to-lisp node state from-list (1+ indent)))
(if (slot-boundp node 'qual)
(pgqa-node-slot-to-lisp node state qual (1+ indent)))
(pgqa-dump-raw-node node-end node state indent))
(defmethod pgqa-dump-raw ((node pgqa-from-list-entry) state indent)
(pgqa-dump-raw-node node-start node state indent)
(if (slot-boundp node 'alias)
(pgqa-node-slot-to-lisp node state alias (1+ indent)))
(if (slot-boundp node 'kind)
(pgqa-simple-slot-to-lisp node state kind (1+ indent)))
(if (slot-boundp node 'args)
(pgqa-list-slot-to-lisp node state args (1+ indent)))
(if (slot-boundp node 'qual)
(pgqa-node-slot-to-lisp node state qual (1+ indent)))
(pgqa-dump-raw-node node-end node state indent))
(defmethod pgqa-dump-raw ((node pgqa-from-list-entry-alias) state indent)
(pgqa-dump-raw-node node-start node state indent)
(pgqa-node-slot-to-lisp node state name (1+ indent))
(if (slot-boundp node 'cols)
(pgqa-node-slot-to-lisp node state cols (1+ indent)))
(pgqa-dump-raw-node node-end node state indent))
(defmethod pgqa-dump-raw ((node pgqa-top-clause) state indent)
(pgqa-dump-raw-node node-start node state indent)
(if (slot-boundp node 'expr)
(pgqa-node-slot-to-lisp node state expr (1+ indent)))
(pgqa-dump-raw-node node-end node state indent))
(defmethod pgqa-dump-raw ((node pgqa-func-call) state indent)
(pgqa-dump-raw-node node-start node state indent)
(pgqa-node-slot-to-lisp node state name (1+ indent))
(when (and (slot-boundp node 'args) (oref node args))
(cl-assert
(object-of-class-p (oref node args) 'pgqa-node-list)
nil
"Function arguments should have been wrapped in a comma operator")
(let ((comma-op (oref node args)))
(pgqa-list-slot-to-lisp comma-op state args (1+ indent))))
(pgqa-dump-raw-node node-end node state indent))
(defmethod pgqa-dump-raw ((node pgqa-string) state indent)
(pgqa-dump-raw-node node-start node state indent)
(pgqa-dump-raw-append state
(format "%s%s\n"
(pgqa-lisp-indent-string (1+ indent))
(oref node value)))
(pgqa-dump-raw-node node-end node state indent))
(defmethod pgqa-dump-raw ((node pgqa-number) state indent)
(pgqa-dump-raw-node node-start node state indent)
(pgqa-dump-raw-append state
(format "%s%s\n"
(pgqa-lisp-indent-string (1+ indent))
(oref node value)))
(pgqa-dump-raw-node node-end node state indent))
(defmethod pgqa-dump-raw ((node pgqa-obj) state indent)
(pgqa-dump-raw-node node-start node state indent)
(pgqa-dump-raw-append state
(format "%s%s\n"
(pgqa-lisp-indent-string (1+ indent))
(mapconcat 'format (oref node args) ".")))
(pgqa-dump-raw-node node-end node state indent))
(defmethod pgqa-dump-raw ((node pgqa-data-type) state indent)
(pgqa-dump-raw-node node-start node state indent)
(pgqa-list-slot-to-lisp node state args (1+ indent)))
(defmethod pgqa-dump-raw ((node pgqa-case) state indent)
(pgqa-dump-raw-node node-start node state indent)
(if (oref node arg)
(pgqa-node-slot-to-lisp node state arg (1+ indent)))
(pgqa-list-slot-to-lisp node state branches (1+ indent))
(if (slot-boundp node 'else)
(pgqa-node-slot-to-lisp node state else (1+ indent)))
(pgqa-dump-raw-node node-end node state indent))
(defmethod pgqa-dump-raw ((node pgqa-case-branch) state indent)
(pgqa-dump-raw-node node-start node state indent)
(pgqa-list-slot-to-lisp node state args (1+ indent))
(pgqa-dump-raw-node node-end node state indent))
(defmethod pgqa-dump-raw ((node pgqa-operator) state indent)
(pgqa-dump-raw-node node-start node state indent)
(pgqa-simple-slot-to-lisp node state op (1+ indent))
(if (slot-boundp node 'args)
(pgqa-list-slot-to-lisp node state args (1+ indent)))
(pgqa-dump-raw-node node-end node state indent))
(defmethod pgqa-dump-raw ((node pgqa-node-list) state indent)
(pgqa-dump-raw-node node-start node state indent)
(if (slot-boundp node 'args)
(pgqa-list-slot-to-lisp node state args (1+ indent)))
(pgqa-dump-raw-node node-end node state indent))
(defmethod pgqa-dump-raw ((node pgqa-target-entry) state indent)
(pgqa-dump-raw-node node-start node state indent)
(pgqa-node-slot-to-lisp node state expr (1+ indent))
(if (slot-boundp node 'alias)
(pgqa-node-slot-to-lisp node state alias (1+ indent)))
(pgqa-dump-raw-node node-end node state indent))
(defmethod pgqa-dump-raw ((node pgqa-alias) state indent)
(pgqa-dump-raw-node node-start node state indent)
(pgqa-simple-slot-to-lisp node state name (1+ indent))
(pgqa-dump-raw-node node-end node state indent))
(defmethod pgqa-dump-raw ((node pgqa-alias-arg) state indent)
(pgqa-dump-raw-node node-start node state indent)
(pgqa-simple-slot-to-lisp node state var (1+ indent))
(if (slot-boundp node 'datatype)
(pgqa-node-slot-to-lisp node state datatype (1+ indent)))
(pgqa-dump-raw-node node-end node state indent))
(provide 'pgqa-dump-raw)
pgqa-0.1/pgqa-node.el 0000644 0001751 0000144 00000044464 13376770703 013040 0 ustar ah users ;; Copyright (C) 2016 Antonin Houska
;;
;; This file is part of PGQA.
;;
;; PGQA 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.
;; PGQA 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 qalong
;; with PGQA. If not, see .
(require 'eieio)
(defclass pgqa-node ()
(
(region
:initarg :region
:documentation "Start and end position of a nonterminal."
)
(markers
:initarg :markers
:documentation "Start and end position in the form of a marker."
)
(insertion
:initarg :insertion
:initform nil
:documentation "An instance of `pgqa-query-string-insertion' if assigned."
)
)
"Class representing a generic node of SQL query tree.")
;; Special node to carry information on region and markers of an operator
;; string. As it's a subclass of pgqa-node, it can be processed by
;; pgqa-setup-node-gui.
(defclass pgqa-gui-node (pgqa-node)
(
;; Currently 'operator or 'func-call. Both for the sake of highlighting.
(parent-kind
:initarg :parent-kind
:documentation "The kind of the owning node"
)
)
)
(defmethod pgqa-node-walk ((node pgqa-gui-node) walker context)
(funcall walker node context))
;; gui can be either a single instance of pgqa-gui-node or a list of them.
(defun pgqa-walk-gui (node walker context)
(let ((gui (oref node gui)))
(if (listp gui)
(pgqa-node-walk-list gui walker context)
(funcall walker gui context)))
)
(defclass pgqa-expr (pgqa-node)
(
(args :initarg :args)
)
"A node representing an operation on one or multiple arguments.")
;; Besides attaching the markers to nodes, add them to pgqa-query-markers, to
;; make cleanup easier.
;;
;; context is currently used to indicate that the regions have been
;; initialized during a dump, which can't easily avoid leading whitespace. So
;; if the value is non-nil, we should skip that whitespace when setting up the
;; marker.
(defun pgqa-setup-node-gui (node context)
"Turn region(s) into a markers to the node."
(let* ((reg-vec (oref node region))
(reg-start (elt reg-vec 0))
(reg-end (elt reg-vec 1))
(m-start (make-marker))
(m-end (make-marker))
(o))
;; If the region might start with a whitespace, skip it (the whitespace).
(when context
(goto-char reg-start)
(while (and (looking-at "\\s-\\|\$")
(< reg-start (point-max)))
(setq reg-start (1+ reg-start))
(goto-char reg-start)))
(set-marker m-start reg-start)
(set-marker m-end reg-end)
;; The insertion types are such that the start and end markers always span
;; only the original region.
(set-marker-insertion-type m-start t)
(set-marker-insertion-type m-end nil)
;; Keep track of markers.
(push m-start pgqa-query-markers)
(push m-end pgqa-query-markers)
(oset node markers (vector m-start m-end)))
)
;; For performance reasons (see the Overlays section of Elisp documentation)
;; we assign the face as text property, although cleanup would be simpler if
;; we assigned the face via overlay.
(defun pgqa-set-node-face (node context)
(if (eq (eieio-object-class node) 'pgqa-gui-node)
(if (slot-boundp node 'markers)
(let* ((m (oref node markers))
(m-start (elt m 0))
(m-end (elt m 1))
(kind (oref node parent-kind))
(face))
(if (eq kind 'operator)
(setq face 'pgqa-operator-face)
(if (eq kind 'func-call)
(setq face 'pgqa-func-call-face)
(error
(format
"Unrecognized kind of gui node parent: %s"
kind))))
(put-text-property m-start m-end
'font-lock-face face))
)
)
)
;; Remove the face added previously by pgqa-set-node-face.
(defun pgqa-reset-node-face (node context)
(if (eq (eieio-object-class node) 'pgqa-gui-node)
(if (slot-boundp node 'markers)
(let* ((m (oref node markers))
(m-start (elt m 0))
(m-end (elt m 1)))
(remove-text-properties m-start m-end
'(font-lock-face nil)))
)
)
)
;; An utility to apply a function to all nodes of a tree.
;;
;; If the walker function changes the nodes, caller is responsible for having
;; taken a copy of the original node.
;;
;; Currently it seems more useful to process the sub-nodes before the actual
;; node.
(defmethod pgqa-node-walk ((node pgqa-node) walker context)
"Run the walker function on sub-nodes and the node itself"
;; It seems safer to force each node to implement this function explicitly
;; than to process the node w/o sub-nodes here.
(error (format "walker method not implemented for %s class"
(eieio-object-class-name node))))
(defun pgqa-node-walk-list (node-list walker context)
"Run the node walker function on each item of a list."
(dolist (node node-list)
(pgqa-node-walk node walker context)))
;; CAUTION! Keep `pgqa-copy-common-query-slots' up-to-date if adding new
;; slots.
(defclass pgqa-query (pgqa-node)
(
(kind :initarg :kind)
(target-expr :initarg :target-expr
:initform nil)
(from-expr :initarg :from-expr
:initform nil)
;; An instance of `group-having-sort-part' class. Only used at parse time,
;; then converted to group-by, having and order-by below.
(group-having-sort-part :initarg :group-having-sort-part
:initform nil)
;; The parts `group-having-sort-part'gets flattened into.
(group-by :initarg :group-by
:initform nil)
(having :initarg :having
:initform nil)
(order-by :initarg :order-by
:initform nil)
;; A list used temporarily when parsing an INSERT query. The first element
;; is table name (eventually to be assigned to target-table' slot). If the
;; list has 2nd element, it's a list of columns (eventually to be assigned
;; to insert-cols slot).
(insert-table-expr :initarg :insert-table-expr
:initform nil)
;; Table subject to INSERT / UPDATE / DELETE.
(target-table :initarg :target-table :initform nil)
;; Column list if the query is INSERT command.
(insert-cols :initarg :insert-cols :initform nil)
;; Either SELECT query or VALUES clause of INSERT command.
(insert-input :initarg :insert-input :initform nil)
)
"A generic SQL query (or subquery).")
(defun pgqa-copy-common-query-slots (dst src)
(oset dst target-expr (oref src target-expr))
(if (oref src from-expr)
(oset dst from-expr (oref src from-expr)))
(if (oref src group-by)
(oset dst group-by (oref src group-by)))
(if (oref src having)
(oset dst having (oref src having)))
(if (oref src order-by)
(oset dst order-by (oref src order-by))))
(defmethod pgqa-node-walk ((node pgqa-query) walker context)
(if (oref node target-expr)
(pgqa-node-walk (oref node target-expr) walker context))
(if (oref node target-table)
(pgqa-node-walk (oref node target-table) walker context))
(if (oref node insert-input)
(pgqa-node-walk (oref node insert-input) walker context))
(if (oref node from-expr)
(let ((fe (oref node from-expr)))
(if (oref fe from-list)
(pgqa-node-walk-list (oref fe from-list) walker context))
(if (slot-boundp fe 'qual)
(pgqa-node-walk (oref fe qual) walker context))))
(if (oref node group-by)
(pgqa-node-walk (oref node group-by) walker context))
(if (oref node having)
(pgqa-node-walk (oref node having) walker context))
(if (oref node order-by)
(pgqa-node-walk (oref node order-by) walker context))
(funcall walker node context))
(defclass pgqa-from-expr (pgqa-node)
(
(from-list :initarg :from-list)
(qual :initarg :qual)
)
"FROM expression of an SQL query."
)
;; A single argument represents table, function, subquery or VALUES clause. If
;; the 'args slot has elements, the FROM list entry is a join.
(defclass pgqa-from-list-entry (pgqa-expr)
(
;; Instance of pgqa-from-list-entry-alias.
(alias :initarg :alias)
;; For a simple entry, the value is one of "table", "function", "query",
;; "values". For join it's "left", "right", "full" (nil implies inner join
;; as long as 'args has 2 elements).
(kind :initarg :kind)
;; Join expression if the entry is a join.
(qual :initarg :qual)
)
"From list entry (table, join, subquery, ...)"
)
(defmethod pgqa-node-walk ((node pgqa-from-list-entry) walker context)
(if (slot-boundp node 'alias)
(funcall walker (oref node alias) context))
;; If node is a join, recurse into the sides and process qualifier.
(let ((args (oref node args)))
(if (= (length args) 2)
(progn
(pgqa-node-walk (car args) walker context)
(pgqa-node-walk (car (cdr args)) walker context)
(pgqa-node-walk (oref node qual) walker context))
;; Process the single argument (query, function, ...).
(cl-assert (= (length args) 1) nil
"from-list entry has incorrect number of arguments")
(pgqa-node-walk (car args) walker context))
(funcall walker node context)))
(defclass pgqa-alias (pgqa-node)
(
(name :initarg :name)
)
"Generic alias."
)
(defclass pgqa-alias-arg (pgqa-node)
(
(var :initarg :var)
;; An instance of `pgqa-data-type'.
(datatype :initarg :datatype)
)
"Alias output column."
)
(defclass pgqa-from-list-entry-alias (pgqa-node)
(
;; Instance of `pgqa-alias'.
(name :initarg :name)
;; If :cols bound, it's an instance of `pgqa-node-list' of `pgqa-alias-arg'
;; items.
(cols :initarg :cols)
)
"From list entry alias."
)
;; This class exists primarily for pgq-dump. Top-level clauses that contain a
;; single expression should be represented by its subclass.
(defclass pgqa-top-clause (pgqa-node)
(
(expr :initarg :expr)
)
"Common class for some other which are dumped in similar way.")
(defmethod pgqa-node-walk ((node pgqa-top-clause) walker context)
(pgqa-node-walk (oref node expr) walker context))
(defclass pgqa-group-clause (pgqa-top-clause)
(
)
"GROUP BY clause.")
;; XXX Shouldn't `pgqa-group-clause' be just renamed to be more generic and
;; used here as well?
(defclass pgqa-having-clause (pgqa-top-clause)
(
)
"HAVING clause.")
(defclass pgqa-sort-clause (pgqa-top-clause)
(
)
"ORDER BY clause.")
;; Wrapper for GROUP BY and HAVING. Since we have a single rule for both (in
;; order to keep the number of rules for the query reasonably low), it makes
;; sense to have both clauses in a single structure. (List could do the work
;; but class makes tree walker(s) easier to read.)
;;
;; This class is only used at parse time. Once parsing is complete, it gets
;; flattened.
;;
;; As the contained clauses do have their GUI nodes, the only reason for this
;; class to inherit from `pgqa-node' is that it has to pass region info to the
;; containing query in the generic way.
(defclass pgqa-group-having-part (pgqa-node)
(
;; Instance of `pgqa-group-clause'.
(group :initarg :group :initform nil)
;; Instance of `pgqa-having-clause'.
(having :initarg :having :initform nil))
)
;; Like above, possibly including ORDER BY.
(defclass pgqa-group-having-sort-part (pgqa-node)
(
;; Instance of `pgqa-group-having-part'.
(group-having :initarg :group-having :initform nil)
;; Instance of `pgqa-sort-clause'.
(sort :initarg :sort :initform nil))
"GROUP BY (possibly including HAVING) and ORDER BY expressions.")
;; Flatten the parse-time classes like `pgqa-group-having-sort-part'.
(defun pgqa-flatten-query-tree (node context)
(if (eq (eieio-object-class node) 'pgqa-query)
(let ((ghs (oref node group-having-sort-part))
(gh)
(kind (oref node kind)))
(when ghs
(setq gh (oref ghs group-having))
(when gh
(oset node group-by (oref gh group))
(oset node having (oref gh having)))
(oset node order-by (oref ghs sort))
;; The slot is no longer needed.
(oset node group-having-sort-part nil))
(when (string= kind "INSERT")
(let ((input (oref node insert-input))
(ite (oref node insert-table-expr)))
;; Copy the actual slots.
(pgqa-copy-common-query-slots node input)
(oset node target-table (car ite))
(if (cdr ite)
(oset node insert-cols (nth 1 ite))))
)
)
)
)
(defclass pgqa-func-call (pgqa-node)
(
(name :initarg :name)
;; arguments are stored as a single pgqa-operator having :op=",".
(args :initarg :args)
;; Like pgqa-operator. XXX Is it worth to define a common parent class for
;; pgqa-func-call, pgqa-operator and possibly some other classes that might
;; be highlighted in the future?
(gui :initarg :gui
:initform nil)
)
"Function call"
)
(defmethod pgqa-node-walk ((node pgqa-func-call) walker context)
(funcall walker (oref node name) context)
(if (oref node args)
(pgqa-node-walk (oref node args) walker context))
(if (oref node gui)
(pgqa-walk-gui node walker context))
(funcall walker node context))
;; String constant.
(defclass pgqa-string (pgqa-node)
(
(value :initarg :value)
)
"A String.")
(defmethod pgqa-node-walk ((node pgqa-string) walker context)
(funcall walker node context))
;; Number is currently stored as a string - should this be changed?
(defclass pgqa-number (pgqa-node)
(
(value :initarg :value)
)
"A number.")
(defmethod pgqa-node-walk ((node pgqa-number) walker context)
(funcall walker node context))
(defclass pgqa-obj (pgqa-expr)
(
;; The :args slot (inherited from pgqa-expr) contains the dot-separated
;; components of table / column reference.
;;
;; XXX Can't we simply use pgqa-expr class here?
;;
;; x.y expression can represent either column "y" of table "x" or table "y"
;; of schema "x". Instead of teaching parser to recognize the context (is
;; it possible?) let's postpone resolution till analysis phase.
;;
;; Note that the number of arguments is not checked during "raw parsing",
;; and that asterisk can be at any position, not only the last one.
)
"Table or column reference.")
(defmethod pgqa-node-walk ((node pgqa-obj) walker context)
;; The individual args are strings, so only process the alias.
(funcall walker node context))
(defclass pgqa-data-type (pgqa-expr)
(
;; The :args slot (inherited from pgqa-expr) contains a list of type name
;; components, each of which should be an instance of pgqa-obj. In most
;; cases it's a single-item list, but can have 2 items at least in one
;; special case ("double precision").
)
"Data type name.")
(defmethod pgqa-node-walk ((node pgqa-data-type) walker context)
(funcall walker node context))
(defclass pgqa-case (pgqa-node)
(
(arg
:initarg :arg
:documentation "The expression following the CASE keyword.")
(branches
:initarg :branches
:documentation "A list of `pgqa-case-branch' instances.")
(else
:initarg :else
:documentation "The ELSE expression.")
)
"CASE expression")
(defmethod pgqa-node-walk ((node pgqa-case) walker context)
(pgqa-node-walk-list (oref node branches) walker context)
(funcall walker node context))
(defclass pgqa-case-branch (pgqa-expr)
(
;; The (inherited) :args slot contains a 2-element list. The first and
;; second element represent arguments of the WHEN and THEN clause
;; respectively.
)
"The \"WHEN ... THEN ...\" part of CASE expression.")
(defmethod pgqa-node-walk ((node pgqa-case-branch) walker context)
(pgqa-node-walk-list (oref node args) walker context)
(funcall walker node context))
(defclass pgqa-operator (pgqa-expr)
(
;; TODO Rename to 'code ?
(op :initarg :op)
;; Region info and marker of the operator string(s) is stored separate so
;; that access to the string remains straightforward. Can be a single
;; instance of pgqa-gui-node or list of those.
(gui :initarg :gui
:initform nil)
(prec :initarg :prec
:documentation "Operator precedence, for the sake of printing.")
(postfix :initarg :postfix
:initform nil
:documentation "If the expression has only one argument, it's
considered to be an unary operator. This slot tells whether it's a postfix
operator. nil indicates it's a prefix operator.")
)
"Generic operator.")
(defmethod pgqa-node-walk ((node pgqa-operator) walker context)
(pgqa-node-walk-list (oref node args) walker context)
(if (oref node gui)
(pgqa-walk-gui node walker context))
(funcall walker node context))
;; Sublink is mostly treated like an operator, but it seems to deserve
;; separate class. The :op slot indicates the sublink kind (e.g. EXISTS), and
;; subquery is the only argument.
;;
;; TODO Simplify instance creation so that the subquery can be passed directly
;; instead of being wrapped in a singl-element list.
(defclass pgqa-sublink (pgqa-operator)
(
)
"Sublink node")
;; Some nodes are actually plain lists, but it's easier to work with a class
;; because it has a name.
(defclass pgqa-node-list (pgqa-operator)
(
(op :initarg op :initform ",")
(prec :initarg prec :initform pgqa-precedence-comma)
)
"List of nodes."
)
(defclass pgqa-target-list (pgqa-node-list)
(
)
"Query target list.")
(defclass pgqa-target-entry (pgqa-node)
(
(expr :initarg :expr)
(alias :initarg :alias)
)
"Target list entry"
)
(defmethod pgqa-node-walk ((node pgqa-target-entry) walker context)
(pgqa-node-walk (oref node expr) walker context)
(funcall walker node context))
(defclass pgqa-query-string-insertion ()
(
;; The inserted string is used as a key. XXX There can be multiple
;; insertions with the same key. Should this slot be renamed or should the
;; insertions be organized in a different way than a single list (e.g. a
;; hash containing a list for each key)?
(key :initarg :key)
;; Where in the buffer the insertion starts and ends.
(start :initarg :start)
(end :initarg :end)
(overlay :initarg :overlay :initform nil))
"If the input query has the form of SQL string, it can consist of parts
concatenated using the SQL concatenation operator (||). Each part is either an
SQL string or an insertion. For example, if PL/pgSQL language is used to
construct the query string, then PL/pgSQL variable representing part of the
string is the insertion.")
(defclass pgqa-string-to-query-context ()
(
(last-insertion :initarg :last-insertion
:initform nil)
)
"Input / output for `pgqa-dump-maybe-insertion'")
(provide 'pgqa-node)
pgqa-0.1/pgqa-parser.el 0000644 0001751 0000144 00000174610 13376770703 013404 0 ustar ah users ;; Copyright (C) 2016 Antonin Houska
;;
;; This file is part of PGQA.
;;
;; PGQA 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.
;; PGQA 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 qalong
;; with PGQA. If not, see .
;; TODO Make byte-compile work. Even after some code rearrangement (eventually
;; reverted), which was necessary for the compiled code to generate the
;; automaton, wisent failed to parse some queries. Can there be something
;; wrong in the way the compiled code calls wisent-parse?
(require 'semantic)
(require 'semantic/lex)
(require 'semantic/wisent/comp)
(require 'pgqa-dump)
;; pgqa-dump-raw contains macros.
(eval-when-compile
(require 'pgqa-dump-raw))
(setq wisent-parse-verbose-flag t)
;; TODO Try defvar at top level instead of doing the setup each time.
(define-lex-regex-analyzer semantic-lex-error
"Detect any unrecognized character. Must be the last analyzer tried."
"."
;; TODO Get both character and line number from the parser state.
(error "Unrecognized character"))
;; SQL string must accept double apostrophe as well as double quotation mark.
(define-lex-simple-regex-analyzer semantic-lex-string-sql
"Recognize SQL string."
"\\('\\([^']\\|\\(''\\)\\)*'\\)\\|\\(\"\\([^\"]\\|\\(\"\"\\)\\)*\"\\)"
'string)
;; Instead of semantic-lex-punctuation analyzer we use
;; semantic-lex-punctuation-multi, to cover multi-character operators.
(define-lex-regex-analyzer semantic-lex-punctuation-multi
"Detect and create punctuation token, which possibly consists of multiple
characters."
"\\(\\s.\\|\\s$\\|\\s'\\)" 'punctuation
(let ((beginning (match-beginning 0))
(end (match-end 0))
(is-dot)
(width-max 0))
(save-excursion
(goto-char beginning)
(setq is-dot (looking-at "\\.")))
;; Find the end of the (supposed) operator, but do not consider a dot to
;; be part of any operator.
(when (null is-dot)
(setq end (re-search-forward "\\(\\s.\\|*\\)*"
(+ (point) pgqa-max-operator-length)))
;; Treat the special case of a colon or a comma following an asterisk in
;; the role of a column wildcard.
(save-excursion
(goto-char (1- end))
(if (and (looking-at "\\(;\\|,\\)") (> (- end beginning) 1))
(setq end (1- end)))))
(semantic-lex-push-token
(semantic-lex-token
'punctuation beginning end))))
;; TODO Add a function to kill "orphan query buffers". User can create them by
;; killing the root buffer, after having removed all query buffer links from
;; it.
(defvar pgqa-automaton nil)
;; If non-nil, pgqa-parse always calls pgqa-init-parser. This is useful during
;; development, when the grammar is changed rather often. nil implies that the
;; parser is only initialized only.
(defvar pgqa-parser-always-init nil)
;; Keywords are stored in a hash table, so that it's easy for the parser to
;; check whether a token is a keyword.
(defvar pgqa-keyword-hash nil)
;; Likewise, store other terminal strings in a hash, to decide quickly if
;; token should be considered a terminal.
;;
;; TODO Consider using a single hash for all terminals.
;;
;; TODO A function that performs all the operator-related initializations, so
;; that it's easy to reload custom operators from PG.
(defvar pgqa-terminal-hash nil)
;; Precedence constants. Do not use the numbers directly.
;;
;; Note that these constants only find their way to the `pgqa-operator' class
;; (for the sake of dump), not to parser.
(defconst pgqa-precedence-cast 10)
(defconst pgqa-precedence-uminus 9)
(defconst pgqa-precedence-times 8)
(defconst pgqa-precedence-add 7)
(defconst pgqa-precedence-other 6)
(defconst pgqa-precedence-like 5)
(defconst pgqa-precedence-cmp 4)
(defconst pgqa-precedence-test 3)
(defconst pgqa-precedence-not 2)
(defconst pgqa-precedence-and 1)
(defconst pgqa-precedence-or 0)
(defconst pgqa-precedence-comma -1)
;; As the grammar definition does not accept terminals in the form of string,
;; a symbol must exist to represent each terminal. We can't use hard-wired
;; symbols in general because PostgreSQL allows user to define custom
;; operators. Therefore we generate symbols for operators by adding numeric
;; prefix to per-group symbol.
;;
;; Each operator group is specific by the "base" symbol, precedence and the
;; actual list of operators. If associativity differs while precedence is
;; equal, use separate groups too.
;;
;; Note that pgqa-precedence-uminus is not used by any group.
(defvar pgqa-operator-group-cast
'(OPGROUP-CAST pgqa-precedence-cast "::"))
(defvar pgqa-operator-group-times
;; ?* isn't there on purpose. It has to be treated separate because of its
;; use as a wildcard. See all references to this group.
'(OPGROUP-TIMES pgqa-precedence-times "/"))
;; Operators defined in the pg_operator catalog are treated equally when
;; terminal symbols are concerned (they have the same precedence), so they all
;; have the same OPGROUP-CAT symbol prefix. However we need them separate when
;; creating grammar rules.
;;
;; First, the binary operators. Use this query to retrieve the list.
;;
;; SELECT string_agg(DISTINCT '"' || oprname || '"', ' ')
;; FROM pg_operator
;; WHERE oprleft > 0 AND oprright > 0 AND oid < 16384
;; AND oprname NOT IN ('>', '<', '=', '<=', '>=', '<>', '/', '*',
;; '+', '-');
;;
(defvar pgqa-operator-group-cat-bin
'(OPGROUP-CAT
pgqa-precedence-other
"^" "~~" "~~*" "~<~" "~<=~" "~=" "~>~" "~>=~" "~" "~*" "<^" "<<=" "<<|"
"<<" "<->" ">" "<@" "<#>" ">^" ">>=" ">>" "|>>" "||" "|" "|&>" "->>"
"->" "-|-" "!~~" "!~~*" "!~" "!~*" "?||" "?|" "?-|" "?-" "?" "?&" "?#"
"@>" "@" "@@" "@@@" "*<=" "*<>" "*<" "*=" "*>=" "*>" "&<|" "&<" "&>" "&"
"&&" "#<=" "#<>" "#<" "#=" "#>=" "#>>" "#>" "#-" "#" "##" "%"
))
;; pg_operator - unary prefix.
;;
;; SELECT string_agg(DISTINCT '"' || oprname || '"', ' ')
;; FROM pg_operator
;; WHERE oprleft = 0 AND oprright > 0 AND oid < 16384
;; AND oprname NOT IN ('>', '<', '=', '<=', '>=', '<>', '/', '*',
;; '+', '-');
(defvar pgqa-operator-group-cat-prefix
'(OPGROUP-CAT
pgqa-precedence-other
"~" "||/" "|/" "|" "!!" "?|" "?-" "@-@" "@" "@@" "#"))
;; pg_operator - unary postfix.
;;
;; SELECT string_agg(DISTINCT '"' || oprname || '"', ' ')
;; FROM pg_operator
;; WHERE oprleft > 0 AND oprright = 0 AND oid < 16384
;; AND oprname NOT IN ('>', '<', '=', '<=', '>=', '<>', '/', '*',
;; '+', '-');
(defvar pgqa-operator-group-cat-postfix
'(OPGROUP-CAT pgqa-precedence-other "!"))
;; Construct a special group for declaration of terminals contained in the
;; `orig' list but not contained in `excl'. This is to ensure that Wisent does
;; not complain about "redefining precedence" of a terminal.
;;
;; In effect, such "ambiguous" operators will be declared as left-associative,
;; as this is important to parse them in the "binary context". On the other
;; hand, associativity is not important for an unary operator, but it
;; shouldn't break things if remains left-associative due to the ambiguity.
;;
;; XXX Not all uses of the operator groups need the symbol, and it appears to
;; be redundant here. Is this worth restructuring the data?
(defun pgqa-operator-group-excl (orig excl)
(let ((result)
(orig-ops (cdr (cdr orig)))
(excl-ops (cdr (cdr excl))))
(dolist (i orig-ops)
(if (null (member i excl-ops))
(push i result)))
(append
(list 'OPGROUP-CAT 'pgqa-precedence-other) result))
)
;; Unique set of operators present in PG catalog (pg_operator) is useful
;; sometimes (although the duplicates probably wouldn't be fatal).
(defvar pgqa-operators-catalog
(let ((ops-cat))
(setq ops-cat (seq-concatenate 'list
(cdr (cdr pgqa-operator-group-cat-bin))
(cdr (cdr pgqa-operator-group-cat-prefix))
(cdr (cdr pgqa-operator-group-cat-postfix))))
(setq ops-cat (delete-dups ops-cat))
(setq ops-cat (append '(OPGROUP-CAT pgqa-precedence-other) ops-cat))))
(defvar pgqa-operator-group-like
'(OPGROUP-LIKE pgqa-precedence-like "LIKE"))
;; Put BETWEEN and IN into a separate group, for the sake of rule creation.
(defvar pgqa-operator-group-like-special
'(OPGROUP-BETWEEN pgqa-precedence-like "BETWEEN" "IN"))
(defvar pgqa-operator-group-cmp
'(OPGROUP-CMP pgqa-precedence-cmp ">" "<" "=" "<=" ">=" "<>"))
(defvar pgqa-operator-group-test
'(OPGROUP-TEST pgqa-precedence-test "IS" "ISNULL" "NOTNULL"))
(defvar pgqa-operator-group-not
'(OPGROUP-NOT pgqa-precedence-not "NOT"))
(defvar pgqa-operator-group-and
'(OPGROUP-AND pgqa-precedence-and "AND"))
(defvar pgqa-operator-group-or
'(OPGROUP-OR pgqa-precedence-or "OR"))
;; Sublinks are actually not operators, but should be treated alike in various
;; contexts.
(defvar pgqa-operator-group-sublink
'(OPGROUP-SUBLINK nil "EXISTS" "ANY" "ALL"))
(defvar pgqa-operator-groups
(list pgqa-operator-group-cast
pgqa-operator-group-times pgqa-operators-catalog
pgqa-operator-group-like pgqa-operator-group-like-special
pgqa-operator-group-cmp
pgqa-operator-group-test pgqa-operator-group-not
pgqa-operator-group-and pgqa-operator-group-or
pgqa-operator-group-sublink))
;; List of all operators (only strings, no metadata from the groups above).
(defvar pgqa-all-operators
(let ((result))
(dolist (g pgqa-operator-groups)
(let ((ops (cdr (cdr g))))
(dolist (op ops)
(push op result))
)
)
result)
)
;; Operators which are considered keywords.
;;
;; These are kept separate for the sake of highlighting: although
;; `pgqa-operator-face' will eventually be assigned to them, highlighting them
;; using `font-lock-keyword-face' until parsing has completed seems useful.
;;
(defvar pgqa-keyword-operators
(let ((result))
(dolist (op pgqa-all-operators)
(if (string-match "[A-Z]+" op)
(push op result)))
result)
)
;; This is needed in semantic-lex-punctuation-multi analyzer.
(defvar pgqa-max-operator-length 0
"Maximum length among non-keyword operators")
;; Terminals not contained explicitly in any group above. These can also be
;; used as a symbol in the grammar definition.
(defvar pgqa-terminals-non-grouped
'(DOUBLE PRECISION))
;; Like above, but only containing a single char.
(defvar pgqa-char-terminals-non-grouped
'(?\; ?. ?, ?* ?+ ?- ?\) ?\( ))
;; Create gramar rule for binary operator.
;;
;; Subclass of pgqa-operator can be passed in, otherwise it defaults to
;; pgqa-operator.
(defun pgqa-create-binop-expr-rule (op opsym prec expr-input
&optional prec-nonterm)
(setq pattern
(list expr-input opsym expr-input))
(setq action
(list 'make-instance
pgqa-operator
:op op :args '(list $1 $3)
:prec prec
:region '(pgqa-union-regions $region1 $1
$region3 $3)
:gui '(pgqa-gui-node
:region (car $region2)
:parent-kind 'operator)))
(if prec-nonterm
(list pattern prec-nonterm action)
(list pattern action)))
;; Create gramar rule for unary prefix operator.
;;
;; `prec-nonterm' is precedence of the non-terminal (expression) for which
;; we're constructing the rule. In contrast, `prec' is precedence used merely
;; to print the query. This is only to handle the special case of unary plus
;; and minus operators. (Nothing like that is needed for postfix operators, as
;; these - being all the user operators - have precedence different from
;; possibly confilicting core operators.)
(defun pgqa-create-prefix-unop-expr-rule
(op opsym prec expr-input &optional prec-nonterm)
(setq pattern
(list opsym expr-input))
(setq action
(list 'make-instance
pgqa-operator
:op op :args '(list $2)
:prec prec
:region '(pgqa-union-regions $region1 $1
$region2 $2)
:gui '(pgqa-gui-node :region (car $region1)
:parent-kind 'operator)))
(if prec-nonterm
(list pattern prec-nonterm action)
(list pattern action)))
;; Likewise, create a rule for postfix operator.
(defun pgqa-create-postfix-unop-expr-rule
(op opsym prec expr-input &optional prec-nonterm)
(setq pattern
(list expr-input opsym))
(setq action
(list 'make-instance
pgqa-operator
:op op :args '(list $1)
:prec prec
:postfix t
:region '(pgqa-union-regions $region1 $1
$region2 $2)
:gui '(pgqa-gui-node
:region (car $region2)
:parent-kind 'operator)))
(if prec-nonterm
(list pattern prec-nonterm action)
(list pattern action))
)
;; Some sublinks can have both query and (array) expression as an
;; argument. Pass arg_query as appropriate.
(defun pgqa-create-sublink-expr-rule (kind arg_query)
(list
;; Pattern
(list (gethash kind pgqa-terminal-hash)
;; Use expr-restr non-terminal instead of expr because logical
;; operators cannot produce arrays.
?\( (if arg_query 'query 'expr-restr) ?\))
;; Action
(list 'make-instance
pgqa-sublink
:op kind :args '(list $3)
:prec nil
:region '(pgqa-union-regions $region1 $1
$region4 $4)
:gui '(pgqa-gui-node :region (car $region1)
:parent-kind 'operator)
)
)
)
(defun pgqa-create-in-expr-rule (input)
(list
;; Pattern
(list 'expr-restr
(gethash "IN" pgqa-terminal-hash)
?\( input ?\))
;; Action
(list 'make-instance
pgqa-operator
:op "IN" :args '(list $1 $4)
:prec pgqa-precedence-like
:region '(pgqa-union-regions $region1 $1
$region5 $5)
:gui '(pgqa-gui-node :region (car $region2)
:parent-kind 'operator)
)
)
)
;; Create rules for given operator group and add them to the list which is
;; eventually used to generate the grammar.
(defun pgqa-create-operator-rules (group result op-hash create-func
expr-input &optional prec-nonterm)
(let* ((gsym (car group))
(rest (cdr group))
(prec (car rest))
(ops (cdr rest)))
(dolist (op ops)
(let ((rule))
;; Use the same symbols that pgqa-terminal-hash should already
;; contain.
(setq sym (gethash op op-hash))
(if prec-nonterm
(setq rule (funcall create-func op sym prec expr-input
prec-nonterm))
(setq rule (funcall create-func op sym prec expr-input)))
(push rule result)))
)
result
)
;; Construct a list of operator symbols for given group. We retrieve them from
;; the hash table because we've constructed most of the symbols
;; programmatically and want them to match wherever comparison takes place.
(defun pgqa-operator-group-symbols (group op-hash)
(let* ((gsym (car group))
(rest (cdr group))
(prec (car rest))
(ops (cdr rest))
(result))
(dolist (op ops result)
(push (gethash op op-hash) result))
result))
;; Keywords in plain format. New keywords should be added here.
;;
;; TODO Consider if strings are safer than symbols, in terms of conflict with
;; other elisp modules.
(defvar pgqa-keyword-symbols
'(AS BY CASE DELETE ELSE END FROM FULL GROUP HAVING INNER INSERT INTO JOIN
LATERAL LEFT LIMIT ON ORDER OUTER RIGHT UPDATE RETURNING SELECT SET
THEN VALUES WHEN WHERE WITH))
(defvar-local pgqa-query-tree nil
"Tree of the last successfully parsed query.")
(defvar pgqa-query-tree-buffer "*pgqa-query-tree-text*"
"Name of buffer to which `pgqa-parse' function writes textual form of the
query tree.")
(defvar-local pgqa-parse-error nil
"Has the last parsing ended up with an error?")
(defun pgqa-get-region-pos(region node start)
"Retrieve start or end position from $regionN Wisent variable or from node,
whichever is available."
(if noninteractive
nil
(let ((vec))
(if region
(setq vec (car region))
(setq vec (oref node region)))
(elt vec (if start 0 1)))))
;; Wisent only seems to support the $region variable for simple non-terminals
;; (is the problem that it can't union multiple values of $region ?) so we
;; need to derive them where necessary. This function does so by retrieving
;; the start position from the first region and the end position from the
;; last one.
(defun pgqa-union-regions(region-1 node-1 region-2 node-2)
(if noninteractive
nil
(vector
(pgqa-get-region-pos region-1 node-1 t)
(pgqa-get-region-pos region-2 node-2 nil))))
;; Get the region in vector format from a single nonterm.
(defun pgqa-get-region(region node)
(if noninteractive
nil
(vector (pgqa-get-region-pos region node t)
(pgqa-get-region-pos region node nil))))
(defun pgqa-init-parser ()
(setq pgqa-keyword-hash (make-hash-table :test 'equal))
(let ((result pgqa-keyword-hash))
(dolist (i pgqa-keyword-symbols result)
(let ((s (format "%s" i)))
;; Althouhgh Wisent would probably complain too, it's simple enought
;; to check for duplicate keywords here.
(if (gethash s result)
(error (format "Duplicate keyword: %s" s)))
;; String is the key so we can lookup token values here, symbol is the
;; value because parser expects symbols.
(puthash s i result)))
)
;; Initialize pgqa-max-operator-length.
(dolist (op pgqa-all-operators)
(if (string-match "\\s." op)
(setq pgqa-max-operator-length
(max pgqa-max-operator-length (string-width op))))
)
(define-lex
simple-lex
"Lexer to provide input for SQL parser."
semantic-lex-ignore-whitespace
semantic-lex-ignore-newline
semantic-lex-ignore-comments
semantic-lex-open-paren
semantic-lex-close-paren
semantic-lex-number
semantic-lex-newline
semantic-lex-whitespace
semantic-lex-symbol-or-keyword
semantic-lex-string-sql
semantic-lex-punctuation-multi
semantic-lex-error)
(let ((grammar-list)
(automaton)
(nonterm-assoc)
(rule-sublist-1)
(rule-sublist-2)
(rule-sublist-3)
(rule-sublist-4)
(rule-sublist-5)
(rule-sublist-6)
(terminals)
(expr-rules)
(expr-restr-rules)
(nonterm-expr)
(nonterm-expr-restr))
(setq terminals (append pgqa-keyword-symbols
pgqa-terminals-non-grouped
pgqa-char-terminals-non-grouped
'(NUMBER STRING SYMBOL)))
;; Initialize the hash in which tokenizer will look-up the terminal
;; symbols.
(setq pgqa-terminal-hash (make-hash-table :test 'equal))
(let ((result pgqa-terminal-hash))
;; Process the operators by groups.
(dolist (group pgqa-operator-groups result)
;; Omit precedence, not needed here.
(let ((gsym (car group))
(ops (cdr (cdr group)))
(i 0)
(sym-str)
(sym))
(dolist (op ops result)
;; Create unique symbol per operator.
(setq sym-str (format "%s_%.3d" (symbol-name gsym) i))
(setq sym (make-symbol sym-str))
(puthash op sym result)
;; Also add it to the list of terminals.
(push sym terminals)
(setq i (1+ i)))))
;; Add symbols not contained in any group.
(dolist (i pgqa-terminals-non-grouped result)
(puthash (symbol-name i) i result))
;; Add characters not contained in any group.
(dolist (i pgqa-char-terminals-non-grouped result)
(puthash (char-to-string i) i result))
)
;; Terminal associativity & precedence
(setq nonterm-assoc
(list
'(left ?\;)
'(left ?,)
(append '(left)
(pgqa-operator-group-symbols
;; OR
pgqa-operator-group-or pgqa-terminal-hash))
(append '(left)
;; AND
(pgqa-operator-group-symbols
pgqa-operator-group-and pgqa-terminal-hash))
(append '(right)
;; NOT
(pgqa-operator-group-symbols
pgqa-operator-group-not pgqa-terminal-hash))
(append '(nonassoc)
;; IS, ISNULL, NOTNULL
(pgqa-operator-group-symbols
pgqa-operator-group-test pgqa-terminal-hash))
(append '(nonassoc)
;; >, <, etc.
(pgqa-operator-group-symbols
pgqa-operator-group-cmp pgqa-terminal-hash))
(append '(nonassoc PREC-BETWEEN)
;; LIKE, BETWEEN, IN, etc.
(pgqa-operator-group-symbols
pgqa-operator-group-like pgqa-terminal-hash)
(pgqa-operator-group-symbols
pgqa-operator-group-like-special pgqa-terminal-hash))
;; pg_operator catalog entries.
;;
;; unary postfix
(append '(nonassoc)
(pgqa-operator-group-symbols
(pgqa-operator-group-excl
pgqa-operator-group-cat-postfix pgqa-operator-group-cat-bin)
pgqa-terminal-hash))
;; unary prefix
;;
;; If operator is both binary and unary, don't add it here
;; again. It'd only cause Wisent warnings, but would have no impact
;; on the actual parsing.
(append '(nonassoc)
(pgqa-operator-group-symbols
(pgqa-operator-group-excl
pgqa-operator-group-cat-prefix pgqa-operator-group-cat-bin)
pgqa-terminal-hash))
;; binary
(append '(left)
(pgqa-operator-group-symbols
pgqa-operator-group-cat-bin pgqa-terminal-hash))
'(left ?+ ?-)
(append '(left ?*)
;; /
(pgqa-operator-group-symbols
pgqa-operator-group-times pgqa-terminal-hash))
;; In PG this is marked as right-associative, while documentation of
;; Bison 2.7 declares it left-associative in examples. Perhaps the
;; problem is that associativity is not applicable here at all - see
;; chapter "5.3.3 Specifying precedence only" in the documentation of
;; Bison 3.0.4.
'(nonassoc UMINUS)
;; XXX PG core declares brackets as left-associative, but I have no
;; idea in which situation the associativity is important.
'(nonassoc ?\[ ?\])
'(nonassoc ?\( ?\))
(append '(left)
;; :: (cast operator)
(pgqa-operator-group-symbols
pgqa-operator-group-cast pgqa-terminal-hash))
'(left ?.)
)
)
;; Create rules for expressions. expr is a generic expression, expr-restr
;; is one that can be used as an argument of "... BETWEEN ... AND ..."
;; operator.
;;
;; The rules are added to the beginning of the list, so high precedences
;; first.
;;
;; TODO Reconsider division into sublists, e.g. aren't there too many
;; sublists?
;; The cast operator needs to be handled separately because its right
;; operand is not a generic expression.
(let* ((group pgqa-operator-group-cast)
(gsym (car group))
(rest (cdr group))
(prec (car rest))
(ops (cdr rest))
;; The pgqa-operator-group-cast group contains a single operator.
(op (car ops)))
(push
(list
(list
'expr-restr (gethash
(nth 2 pgqa-operator-group-cast)
pgqa-terminal-hash) 'data-type)
(list 'make-instance
'pgqa-operator
:op op :args '(list $1 $3)
:prec prec
:region '(pgqa-union-regions $region1 $1
$region3 $3)
:gui '(pgqa-gui-node
:region (car $region2)
:parent-kind 'operator)))
rule-sublist-1)
)
(setq rule-sublist-1
(pgqa-create-operator-rules
pgqa-operator-group-times rule-sublist-1 pgqa-terminal-hash
'pgqa-create-binop-expr-rule 'expr-restr))
;; Asterisk can also be used as wildcard in object names, so handle it
;; separate from the pgqa-operator-group-times group. However the
;; precedence must match pgqa-operator-group-times.
(push (pgqa-create-binop-expr-rule "*" ?* pgqa-precedence-times
'expr-restr)
rule-sublist-1)
;; + and - can be used as unary operators, so they don't fit our concept of
;; groups. Create the rules separate.
(push (pgqa-create-binop-expr-rule "+" ?+ pgqa-precedence-add
'expr-restr)
rule-sublist-1)
(push (pgqa-create-binop-expr-rule "-" ?- pgqa-precedence-add
'expr-restr)
rule-sublist-1)
(setq rule-sublist-1
(pgqa-create-operator-rules
;; pg_operator - binary.
pgqa-operator-group-cat-bin rule-sublist-1 pgqa-terminal-hash
'pgqa-create-binop-expr-rule 'expr-restr))
(setq rule-sublist-1
(pgqa-create-operator-rules
;; pg_operator - unary prefix.
pgqa-operator-group-cat-prefix rule-sublist-1 pgqa-terminal-hash
'pgqa-create-prefix-unop-expr-rule 'expr-restr))
(setq rule-sublist-1
(pgqa-create-operator-rules
;; pg_operator - unary postfix.
pgqa-operator-group-cat-postfix rule-sublist-1 pgqa-terminal-hash
'pgqa-create-postfix-unop-expr-rule 'expr-restr))
(setq rule-sublist-1
(pgqa-create-operator-rules
;; LIKE, ...
pgqa-operator-group-like rule-sublist-1 pgqa-terminal-hash
'pgqa-create-binop-expr-rule 'expr-restr))
;; Handle the special case of BETWEEN operator.
;;
;; expr-restr must be used as input so that there are not shift/reduce
;; conflicts. For example, if the first argument was a logical AND
;; operator, it should have higher precedence than the following BETWEEN
;; (so that the argument is reduced before being passed to BETWEEN) but
;; BETWEEN has higher precedence than AND in general.
;;
;; XXX It's not clear to me why postgres only has the 2nd argument
;; restricted. Is that due to difference in conflict handling between
;; bison and wisent?
(setq rule-sublist-2
(list
(list
;; Pattern.
(list 'expr-restr
(gethash "BETWEEN" pgqa-terminal-hash)
'expr-restr
(gethash "AND" pgqa-terminal-hash)
'expr)
;; XXX Is this necessary? (See also the occurrence in
;; nonterm-assoc.)
[PREC-BETWEEN]
;; Action
(list 'make-instance
pgqa-operator
:op "BETWEEN" :args '(list $1 $3 $5)
:prec pgqa-precedence-like
:region '(pgqa-union-regions $region1 $1
$region5 $5)
:gui '(list
;; The BETWEEN keyword.
(pgqa-gui-node :region (car $region2)
:parent-kind 'operator)
;; The AND keyword.
(pgqa-gui-node :region (car $region4)
:parent-kind 'operator))
)
)
)
)
;; IN and sublink rules must fall into expr-restr-rules so they can be
;; used as input of binary operators, etc. It does not seem matter to
;; which particular sublist we add them, as long as the sublist ends up in
;; expr-restr-rules.
(push
(pgqa-create-in-expr-rule 'query) rule-sublist-3)
;; TODO During analysis check that neither ALL nor ANY is at the top of
;; the expression tree.
(push
(pgqa-create-sublink-expr-rule "ALL" t) rule-sublist-3)
(push
(pgqa-create-sublink-expr-rule "ALL" nil) rule-sublist-3)
(push
(pgqa-create-sublink-expr-rule "ANY" t) rule-sublist-3)
(push
(pgqa-create-sublink-expr-rule "ANY" nil) rule-sublist-3)
(push
(pgqa-create-sublink-expr-rule "EXISTS" t) rule-sublist-3)
;; IN (expressin list) is actually not a sublink, but this seems to be the
;; best location for it in the rule list.
(push
(pgqa-create-in-expr-rule 'expr-list) rule-sublist-3)
(setq rule-sublist-3
(pgqa-create-operator-rules
;; >, <, etc.
pgqa-operator-group-cmp rule-sublist-3 pgqa-terminal-hash
'pgqa-create-binop-expr-rule 'expr-restr))
;; Start a new sub-list so that we can exclude the following rules from
;; expr-restr.
(setq rule-sublist-4
(pgqa-create-operator-rules
;; IS, ISNULL, NOTNULL
pgqa-operator-group-test rule-sublist-4 pgqa-terminal-hash
'pgqa-create-postfix-unop-expr-rule 'expr))
(setq rule-sublist-4
(pgqa-create-operator-rules
;; NOT
pgqa-operator-group-not rule-sublist-4 pgqa-terminal-hash
'pgqa-create-prefix-unop-expr-rule 'expr))
(setq rule-sublist-4
(pgqa-create-operator-rules
;; AND
pgqa-operator-group-and rule-sublist-4 pgqa-terminal-hash
'pgqa-create-binop-expr-rule 'expr))
(setq rule-sublist-4
(pgqa-create-operator-rules
;; OR
pgqa-operator-group-or rule-sublist-4 pgqa-terminal-hash
'pgqa-create-binop-expr-rule 'expr))
;; TODO Create a group for these as well, and possibly replace
;; rule-sublist-1 and rule-sublist-2 with a single list. (The API was not
;; generic enough when this part was being implemented.)
(push (pgqa-create-prefix-unop-expr-rule "+" ?+ pgqa-precedence-uminus
'expr-restr '[UMINUS])
rule-sublist-5)
(push (pgqa-create-prefix-unop-expr-rule "-" ?- pgqa-precedence-uminus
'expr-restr '[UMINUS])
rule-sublist-5)
(setq rule-sublist-6
'(
((NUMBER)
(make-instance 'pgqa-number :value $1
:region (pgqa-get-region $region1 $1))
)
((STRING)
(make-instance 'pgqa-string :value $1
:region (pgqa-get-region $region1 $1))
)
((sql-object)
$1
)
)
)
;; CASE expression.
(push
'(
;; Pattern.
(case-expr-header case-expr-branches ELSE expr END)
;; Action
;;
;; header is a 2-element list containing the argument (i.e. the
;; expression following the CASE keyword or nil if there's no argument)
;; and region of the CASE keyword.
(let ((header $1))
(make-instance
'pgqa-case
:arg (car header)
:branches $2
:else $4
:region (pgqa-union-regions (cdr header) nil $region5 $5)
)
)
)
rule-sublist-6)
(push
'(
;; Pattern.
(case-expr-header case-expr-branches END)
;; Action
(let ((header $1))
(make-instance
'pgqa-case
:arg (car header)
:branches $2
:region (pgqa-union-regions (cdr header) nil $region3 $3)
)
)
)
rule-sublist-6)
(setq expr-restr-rules
(seq-concatenate
'list
rule-sublist-1
rule-sublist-3
rule-sublist-5
rule-sublist-6
;; Function expression.
'(
;; It seems better to use sql-object and eliminate the
;; inappropriate cases during analysis than to define another,
;; very similar non-terminal.
((sql-object ?\( expr-list ?\))
(make-instance 'pgqa-func-call
:name $1
:args $3
:region (pgqa-union-regions $region1 $1
$region4 $4)
:gui (list
;; The function name.
(make-instance
pgqa-gui-node
:region (car $region1)
:parent-kind 'func-call)
;; Left parenthesis.
(make-instance
pgqa-gui-node
:region (car $region2)
:parent-kind 'func-call)
;; Right parenthesis.
(make-instance
pgqa-gui-node
:region (car $region4)
:parent-kind 'func-call)))
)
((sql-object ?\( ?\))
(make-instance 'pgqa-func-call
:name $1
:args nil
:region (pgqa-union-regions $region1 $1
$region3 $3)
:gui (list
;; The function name.
(make-instance
pgqa-gui-node
:region (car $region1)
:parent-kind 'func-call)
;; Left parenthesis.
(make-instance
pgqa-gui-node
:region (car $region2)
:parent-kind 'func-call)
;; Right parenthesis.
(make-instance
pgqa-gui-node
:region (car $region3)
:parent-kind 'func-call)))
)
)
;; Single expression parenthesized or a row expression.
'(
((?\( expr-list ?\))
(let ((l $2))
(oset l region (pgqa-union-regions $region1 $1 $region3 $3))
l)
)
)
)
)
(setq nonterm-expr-restr
(cons 'expr-restr expr-restr-rules))
;; The rules not present in expr-restr-rules.
;;
;; (The expr-restr rule does not include logical operators because these
;; make no sense as arguments of "BETWEEN ... AND ...".)
(setq expr-rules
(seq-concatenate
'list
rule-sublist-4
rule-sublist-2
)
)
;; Generic expression includes everything that matches expr-restr as well
;; as logical operators and "BETWEEN ... AND ...". Thus the logical
;; operators can accept any expressions, not only expr-restr.
(setq nonterm-expr (append '(expr ((expr-restr))) expr-rules))
(setq grammar-list
(append
'(
;; For terminals we've constructed terminals list which we'll
;; eventually cons to the list beginning. The other elements are
;; literals.
;;
;; Likewise, we'll cons separately constructed list
;; nonterm-assoc that specifies associativity of non-terminal
;; symbols.
;; Non-terminals.
(input
((query)
$1)
((query ?\;)
(let ((q $1))
(oset q region (pgqa-union-regions nil q $region2 nil))
q)
)
)
(query
((select-query)
$1)
((insert-query)
$1)
((update-query)
$1)
)
(insert-query
((INSERT INTO insert-table-expr select-query)
(make-instance 'pgqa-query :kind "INSERT"
:insert-table-expr $3
:insert-input $4
:region (pgqa-union-regions
$region1 nil nil $4))
)
)
(insert-table-expr
((sql-object)
(list $1))
((sql-object ?\( insert-col-list ?\) )
(list $1 $3))
)
(insert-col-list
((insert-col-list-entry)
(make-instance 'pgqa-node-list
:args (list $1)
:prec pgqa-precedence-comma
:region (pgqa-get-region $region1 nil))
)
((insert-col-list ?, insert-col-list-entry)
(let* ((nl $1))
(oset nl args (append (oref $1 args) (list $3)))
(oset nl region (pgqa-union-regions nil nl nil $3))
nl)
)
)
(insert-col-list-entry
((SYMBOL)
(make-instance 'pgqa-obj
:args (list $1)
:region (pgqa-get-region $region1 nil))))
(select-query
((select-expr)
(make-instance 'pgqa-query :kind "SELECT"
;; $1 should be instance of pgqa-expr, with
;; comma operator as the single arg.
:target-expr (car (oref $1 args))
:region (pgqa-get-region $region1 $1))
)
((select-expr from-expr)
(make-instance 'pgqa-query :kind "SELECT"
:target-expr (car (oref $1 args))
:from-expr $2
:region (pgqa-union-regions nil $1 nil $2))
)
((select-expr from-expr group-having-sort-part)
(make-instance 'pgqa-query :kind "SELECT"
:target-expr (car (oref $1 args))
:from-expr $2
:group-having-sort-part $3
:region (pgqa-union-regions nil $1 nil $3))
)
)
(update-query
((update-expr update-set-expr)
(make-instance 'pgqa-query :kind "UPDATE"
;; $2 should be pgqa-expr, having the targetlist
;; as the single element of args.
:target-expr (car (oref $2 args))
;; Likewise, $1 wraps the target table.
:target-table (car (oref $1 args))
:region (pgqa-union-regions nil $1 nil $2))
)
((update-expr update-set-expr where-expr)
(let ((from-expr
(make-instance 'pgqa-from-expr
:from-list nil
:qual (car (oref $3 args))
:region (pgqa-get-region
nil $3))))
(make-instance 'pgqa-query :kind "UPDATE"
:target-expr (car (oref $2 args))
:target-table (car (oref $1 args))
:from-expr from-expr
:region (pgqa-union-regions nil $1 nil $3))
)
)
((update-expr update-set-expr from-expr)
(make-instance 'pgqa-query :kind "UPDATE"
:target-expr (car (oref $2 args))
:target-table (car (oref $1 args))
:from-expr $3
:region (pgqa-union-regions nil $1 nil $3))
)
)
(select-expr
((SELECT target-list)
(let* ((tl $2)
(args (oref tl :args))
(last (nth (1- (length args)) args)))
;; Use pgqa-expr to transfer region info to the containing
;; node.
(make-instance 'pgqa-expr
:args (list tl) ;; `tl' is pgqa-target-list
;; instance (comma).
:region (pgqa-union-regions
$region1 nil nil last)))
)
)
(update-expr
;; Since the table can have alias, let's accept from-list-entry
;; now and check for illegal kinds during analysis.
((UPDATE from-list-entry)
;; Use pgqa-expr to transfer region info to the containing
;; node.
(make-instance 'pgqa-expr
:args (list $2)
:region (pgqa-union-regions
$region1 nil nil $2))
)
)
;; TODO During analysis, set precedence of the top level "=" of
;; each list entry low enough (pgqa-precedence-comma, renamed to
;; something more generic, or introduce new special value,
;; e.g. pgqa-precedence-assign) so that the right side is not
;; parenthesized.
(update-set-expr
((SET target-list)
;; TODO A macro that creates the instance for update-set-expr,
;; select-expr and returning-expr. Maybe for where-expr too.
(let* ((tl $2)
(args (oref tl :args))
(last (nth (1- (length args)) args)))
(make-instance 'pgqa-expr
:args (list tl)
:region (pgqa-union-regions
$region1 nil nil last)))
)
)
(target-list
((target-entry)
(make-instance 'pgqa-target-list
:args (list $1)
:region (pgqa-get-region $region1 $1))
)
((target-list ?, target-entry)
(let* ((tl $1)
(args (oref tl args))
(first (car args)))
;; Append a single-element list. If we appended just the
;; element, it'd result in a "dotted list" and such cannot be
;; iterated easily.
(oset tl args (append args (list $3)))
;; Propagate the region info of list elements to the FROM
;; expression as whole.
(oset tl region (pgqa-union-regions nil first nil $3))
tl)
)
)
(target-entry
((expr)
(make-instance 'pgqa-target-entry :expr $1
:region (pgqa-get-region $region1 $1))
)
((expr alias-common)
(make-instance 'pgqa-target-entry :expr $1
:alias $2
:region (pgqa-union-regions $region1 $1
$region2 $2))
)
)
(from-expr
((FROM from-list)
(let* ((l $2)
(last (nth (1- (length l)) l)))
(make-instance 'pgqa-from-expr :from-list l
;; Propagate the region info of list elements
;; to the FROM expression as whole.
:region (pgqa-union-regions $region1 nil
nil last))))
((FROM from-list where-expr)
(let ((qual (car (oref $3 args))))
(make-instance 'pgqa-from-expr :from-list $2 :qual qual
:region (pgqa-union-regions
$region1 nil nil $3))
)
)
)
(where-expr
((WHERE expr)
;; Use pgqa-expr to transfer region info to the containing node.
(make-instance 'pgqa-expr :args (list $2)
:region (pgqa-union-regions
$region1 nil nil $2))))
(from-list
((from-list-entry)
(list $1)
)
((from-list ?, from-list-entry)
;; See target-list for comment about appending single-item list.
(append $1 (list $3))
)
)
(join-expr
((from-list-entry join-op from-list-entry ON expr)
(make-instance 'pgqa-from-list-entry :args (list $1 $3)
:kind $2
:qual $5
:region (pgqa-union-regions $region1 $1
$region5 $5))
)
((?\( join-expr ?\))
$2)
)
(join-op
((JOIN)
;; See the 'kind slot of pgqa-from-list-entry class.
nil
)
((INNER JOIN)
nil
)
((LEFT JOIN)
"left"
)
((LEFT OUTER JOIN)
"left"
)
((RIGHT JOIN)
"right"
)
((RIGHT OUTER JOIN)
"right"
)
((FULL JOIN)
"full"
)
)
(from-list-entry
((join-expr)
$1)
((?\( join-expr ?\) from-list-entry-alias)
(let ((j $2))
(oset j alias $4)
(oset j region
(pgqa-union-regions $region1 $1 $region2 $4))
j)
)
((sql-object)
(make-instance 'pgqa-from-list-entry :kind "table"
:args (list $1)
:region (pgqa-get-region $region1 $1))
)
((sql-object from-list-entry-alias)
(make-instance 'pgqa-from-list-entry :kind "table"
:args (list $1) :alias $2
:region (pgqa-union-regions $region1 $1
$region2 $2))
)
;; Separate rules exist for a function in the FROM list. At
;; least the alias (which can contain column list) makes it
;; distinct from the function expression as defined in
;; expr-rules. In fact, PG does require alias here, so the rules
;; for function expressions would be useless.
;;
;; (Like with function expression, we need to check during
;; analysis if the sql-object is acceptable, e.g. it's not a
;; number or does not contain an asterisk.)
((sql-object ?\( expr-list ?\) from-list-entry-alias)
(let* ((reg-fc (pgqa-union-regions $region1 $1 $region4 $4))
(fc (make-instance 'pgqa-func-call :name $1 :args $3
:region reg-fc
:gui (list
;; The function name.
(make-instance
'pgqa-gui-node
:region (car $region1)
:parent-kind 'func-call)
;; Left parenthesis.
(make-instance
'pgqa-gui-node
:region (car $region2)
:parent-kind 'func-call)
;; Right parenthesis.
(make-instance
'pgqa-gui-node
:region (car $region4)
:parent-kind 'func-call))))
(alias-expr $5))
(make-instance 'pgqa-from-list-entry :kind "function"
:args (list fc)
:alias alias-expr
:region (pgqa-union-regions nil fc nil
alias-expr)))
)
((sql-object ?\( ?\) from-list-entry-alias)
(let* ((reg-fc (pgqa-union-regions $region1 $1 $region3 $3))
(fc (make-instance 'pgqa-func-call :name $1 :args nil
:region reg-fc
:gui (list
;; The function name.
(make-instance
'pgqa-gui-node
:region (car $region1)
:parent-kind 'func-call)
;; Left parenthesis.
(make-instance
'pgqa-gui-node
:region (car $region2)
:parent-kind 'func-call)
;; Right parenthesis.
(make-instance
'pgqa-gui-node
:region (car $region3)
:parent-kind 'func-call)))))
(make-instance 'pgqa-from-list-entry :kind "function"
:args (list fc)
:alias $4
:region (pgqa-union-regions nil fc nil $4)))
)
;; XXX Should we allow a subquery w/o alias and error out during
;; analysis? The error message generated by parser is not just
;; user-friendly.
((?\( query ?\) from-list-entry-alias)
(make-instance 'pgqa-from-list-entry :kind "query"
:args (list $2)
:alias $4
:region (pgqa-union-regions $region1 nil
nil $4))
)
)
(from-list-entry-alias
((alias-common)
(make-instance 'pgqa-from-list-entry-alias
:name $1
:region (pgqa-get-region $region1 $1))
)
((alias-common ?\( alias-args ?\))
(make-instance 'pgqa-from-list-entry-alias
:name $1
:cols $3
:region (pgqa-union-regions nil $1
$region4 nil))
)
)
;; Alias of a target entry, or the common part of an alias of a
;; FROM list entry.
(alias-common
((SYMBOL)
(make-instance 'pgqa-alias
:name $1
:region (pgqa-get-region $region1 nil))
)
((AS SYMBOL)
(make-instance 'pgqa-alias
:name $2
:region (pgqa-get-region $region2 nil))
)
)
;; TODO During analysis check that 1. only function can have the
;; data type specified, 2. for functions check whether PG allows
;; only some columns to have the data type specified. If it does
;; not, check that args of this alias follow the PG restrictions.
(alias-args
((alias-arg)
(make-instance 'pgqa-node-list
:args (list $1)
:prec pgqa-precedence-comma
:region (pgqa-get-region nil $1))
)
((alias-args ?, alias-arg)
(let* ((orig $1)
(args (oref orig args)))
(oset $1 args (append args (list $3)))
(oset $1 region
(pgqa-union-regions nil $1 nil $3))
$1)
)
)
(alias-arg
((SYMBOL)
(make-instance 'pgqa-alias-arg
:var $1
:region (pgqa-get-region $region1 nil))
)
((SYMBOL data-type)
(make-instance 'pgqa-alias-arg
:var $1
:datatype $2
:region (pgqa-union-regions $region1 nil
nil $2))
)
)
(group-having-sort-part
((group-having-part)
(make-instance 'pgqa-group-having-sort-part
:group-having $1
:region (oref $1 region)))
((group-having-part sort-clause)
(make-instance 'pgqa-group-having-sort-part
:group-having $1
:sort $2
:region (pgqa-union-regions
nil $1 nil $2)))
((sort-clause)
(make-instance 'pgqa-group-having-sort-part
:sort $1
:region (oref $1 region))))
(group-having-part
((group-clause)
(make-instance 'pgqa-group-having-part
:group $1
:region (oref $1 region))
)
((group-clause having-clause)
(make-instance 'pgqa-group-having-part
:group $1
:having $2
:region (pgqa-union-regions
nil $1 nil $2))
)
)
(group-clause
((GROUP BY sort-group-list)
(make-instance 'pgqa-group-clause
:expr $3 ;; $3 is pgqa-operator instance
:region (pgqa-union-regions
$region1 nil nil $3))
)
)
(having-clause
((HAVING sort-group-list)
(make-instance 'pgqa-having-clause
:expr $2 ;; $3 is pgqa-target-list instance.
:region (pgqa-union-regions
$region1 nil nil $2))
)
)
(sort-clause
((ORDER BY sort-group-list)
(make-instance 'pgqa-sort-clause
:expr $3 ;; $3 is pgqa-target-list instance
:region (pgqa-union-regions
$region1 nil nil $3))
)
)
(sort-group-list
((expr-list)
;; Turn the list of operators into a list of target entries so
;; it's handled correctly by pgqa-dump (Here we refer to
;; pgqa-clause-item-newline, which is currently applied only to
;; instances of pgqa-target-entry and pgqa-from-list-entry
;; class.)
;;
;; We could use target-list rule instead of expr-list, but that
;; would let the parser accept invalid syntax and make
;; consequent checks harder.
(let ((op-args (oref $1 args))
(args-new))
(dolist (arg op-args)
(let ((te))
(setq te
(make-instance 'pgqa-target-entry
:expr arg
:region (oref arg region)))
(setq args-new (append args-new (list te)))))
(make-instance 'pgqa-target-list
:args args-new
:region (oref $1 region))
)
)
)
)
;; CASE expression components.
'(
(case-expr-header
((CASE)
(list nil (pgqa-get-region $region1 $1)))
((CASE expr)
(list $2 (pgqa-union-regions $region1 nil nil $2)))
)
(case-expr-branches
((case-expr-branch)
(list $1))
((case-expr-branches case-expr-branch)
(append $1 (list $2)))
)
(case-expr-branch
((WHEN expr THEN expr)
(make-instance 'pgqa-case-branch
:args (list $2 $4)
:region (pgqa-union-regions
$region1 $1
$region4 $4))
)
)
)
'(
(expr-list
((expr)
(make-instance 'pgqa-node-list
:args (list $1)
:prec pgqa-precedence-comma
:region (pgqa-get-region $region1 $1))
)
((expr-list ?, expr)
(let* ((orig $1)
(args (oref orig args)))
(oset $1 args (append args (list $3)))
(oset $1 region
(pgqa-union-regions $region1 $1 $region3 $3))
$1)
)
)
)
(list nonterm-expr)
(list nonterm-expr-restr)
'(
(data-type
((sql-object)
(make-instance 'pgqa-data-type
:args (list $1)
:region (pgqa-get-region $region1 $1)))
;; This special case should not be treated using (sql-object
;; sql-object) pattern because that would catch constructs like
;; "sql-object::sql-object sql-object" where only the 2nd
;; sql-object is actually the data type and the 3rd sql-object
;; is an alias.
((DOUBLE PRECISION)
(make-instance 'pgqa-data-type
:args (list
(make-instance 'pgqa-obj :args (list $1)
:region (pgqa-get-region
$region1 $1))
(make-instance 'pgqa-obj :args (list $2)
:region (pgqa-get-region
$region2 $2)))
:region (pgqa-union-regions $region1 $1
$region2 $2)))
)
(sql-object
((SYMBOL)
(make-instance 'pgqa-obj :args (list $1)
:region (pgqa-get-region $region1 $1))
)
((sql-object ?. SYMBOL)
(make-instance 'pgqa-obj
:args (append (oref $1 args) (list $3))
:region (pgqa-union-regions $region1 $1
$region3 $3))
)
((?*)
(make-instance 'pgqa-obj :args (list $1)
:region (pgqa-get-region $region1 $1))
)
((sql-object ?. ?*)
(make-instance 'pgqa-obj :args (append (oref $1 args) (list $3))
:region (pgqa-union-regions $region1 $1
$region3 $3))
)
)
;; (error
;; (progn "Error"))
)
)
)
(setq grammar-list
(cons nonterm-assoc grammar-list))
;; Now finish the grammar by adding the terminal symbols;
(setq grammar-list (cons terminals grammar-list))
(setq automaton (wisent-compile-grammar grammar-list))
(setq pgqa-automaton automaton))
)
;; This is the lexer function providing input for wisent parser.
(defun get-next-query-token ()
(let ((tok)
(kind)
(pos)
(value)
(key)
(result))
(if (not (null query-tokens))
(progn
(setq tok (pop query-tokens))
(setq kind (car tok))
(setq pos (cdr tok))
(setq start (car pos))
(setq end (cdr pos))
(setq value
(buffer-substring-no-properties start end))
(setq result
(list
(cond
((and (eq kind 'symbol)
(setq key (gethash (upcase value)
pgqa-keyword-hash nil))
)
key)
;; TODO Consider only assertion statement for the token
;; kind, or removal of these conditions altogether.
((and (or (eq kind 'punctuation) (eq kind 'symbol)
(eq kind 'open-paren) (eq kind 'close-paren))
(setq key (gethash (upcase value) pgqa-terminal-hash nil)))
key)
((eq kind 'number)
'NUMBER)
;; Generic symbol (table / column name, etc.)
((eq kind 'symbol)
'SYMBOL)
((and (eq kind 'string)
(string= (substring value 0 1) "\""))
'SYMBOL)
((eq kind 'string)
'STRING)
(t (nth 0 tok)))
value (vector start end))))
(setq result (list wisent-eoi-term)))
result))
;; Move point to the symbol that caused the error.
(defun pgqa-parse-message (msg &rest args)
(let ((positions (nth 2 wisent-input))
(problem))
(print wisent-input)
(if (= (length wisent-input) 1)
(if (eq (car wisent-input) wisent-eoi-term)
(progn
(setq positions (list (1- (elt pgqa-last-region 1))))
(setq msg "Unexpected end of input"))
;; This should not happen.
(error "Unrecognized parser state")))
(goto-char (elt positions 0))
(setq pgqa-parse-error t)
;; Replace the (generated) operator symbols with the appropriate strings.
(maphash
(lambda (op sym)
(if (symbolp sym)
(setq msg (replace-regexp-in-string
(symbol-name sym)
(format "'%s'" op) msg))))
pgqa-terminal-hash)
(setq problem (make-instance
'pgqa-problem
:message msg
:location positions))
(pgqa-show-problems (list problem) (current-buffer)))
)
(defun pgqa-parse (&optional text-only)
"Parse the SQL query contained in the buffer and bind result to
`pgqa-query-tree' variable. If the variable already contained another tree,
it's replaced."
(interactive)
;; Enforce the text-only mode if the buffer is not in pgqa-mode or if it's
;; in batch mode. User is not supposed to pass the text-only as a prefix
;; argument when calling the function interactively.
(if (and (null text-only)
(or (null (equal major-mode 'pgqa-mode)) noninteractive))
(setq text-only t))
(pgqa-parse-common text-only)
;; Show the query tree if needed and possible.
(when (and (null noninteractive)
(equal major-mode 'pgqa-mode))
(get-buffer-create pgqa-query-tree-buffer)
(let ((state))
(setq state
(make-instance 'pgqa-dump-raw-state
:node-start 'pgqa-node-to-lisp-start
:node-end 'pgqa-node-to-lisp-end
:result ""))
(pgqa-dump-raw pgqa-query-tree state 0)
(with-current-buffer pgqa-query-tree-buffer
(atomic-change-group
(erase-buffer)
(insert (oref state result))))))
(let ((context)
(problems))
;; Perform query analysis.
(setq context (make-instance 'pgqa-analyze-context))
(pgqa-node-walk pgqa-query-tree 'pgqa-analyze-node context)
(setq problems (oref context problems))
(setq nproblems (length problems))
(pgqa-show-problems problems (current-buffer)))
)
;; text-only tells that no markers, faces, etc. should be added to the query.
(defun pgqa-parse-common (&optional text-only)
"Parsing functionality used for both interactive and batch mode."
(setq pgqa-parse-error nil)
;; Do cleaup if this is not the first parsing.
(when pgqa-query-tree
;; User might explicitly reject the GUI after having created it earlier,
;; so text-only does not matter here.
(pgqa-reset-query-faces pgqa-query-tree)
;; Umark SQL string insertions if there are any. XXX Consider adding
;; parse-only argument to this function to indicate that no formatting
;; will take place. In such a case we wouldn't have to remove the faces.
(pgqa-reset-sql-string-insertion-face)
;; Always delete the GUI, to avoid memory leakage (especially with respect
;; to markers). Also regardless text-only.
(pgqa-delete-query-gui)
(setq pgqa-query-tree nil))
(if (or (null pgqa-automaton) pgqa-parser-always-init)
(pgqa-init-parser))
;; TODO Check this needs to be repeated. Currently it seems related to
;; erase-buffer, which we call from pgqa-deparse. Preferrably it should only
;; be called from pgqa-init-parser.
(semantic-lex-init)
(let ((result)
(start)
(end))
;; Initialize or update pgqa-last-region.
(pgqa-set-region)
;; Get the start and end positions.
(let ((m-start (car pgqa-last-region))
(m-end (car (cdr pgqa-last-region))))
(setq start (marker-position m-start))
(setq end (marker-position m-end)))
(setq-local query-tokens (simple-lex start end)))
(setq result
(wisent-parse pgqa-automaton 'get-next-query-token
'pgqa-parse-message 'input))
;; Only update the existing tree if parsing did complete.
(when (null pgqa-parse-error)
;; Flatten the nodes we only needed for parsing. Use the walker machinery
;; to ensure recursion into subqueries.
(pgqa-node-walk result 'pgqa-flatten-query-tree nil)
;; TODO Reconsider placing of the atomic-change-group form so they are not
;; nested.
;;
;;(atomic-change-group
(if (null text-only)
(progn
(pgqa-setup-query-gui result nil)
(pgqa-set-query-faces result)
(pgqa-set-sql-string-insertion-face pgqa-sql-string-insertions))
;; Except for batch mode, the query should always have the markers
;; set. This is important so that we know at which position deparsing
;; should start.
(if (null noninteractive)
(let* ((reg-vec (oref result region))
(reg-start (elt reg-vec 0))
(reg-end (elt reg-vec 1))
(m-start (make-marker))
(m-end (make-marker)))
;; TODO Consider reusing the code we already have in
;; pgqa-setup-node-gui.
(set-marker m-start reg-start)
(set-marker m-end reg-end)
(set-marker-insertion-type m-start t)
(set-marker-insertion-type m-end nil)
(oset result markers (vector m-start m-end))))
)
(setq pgqa-query-tree result))
)
(defun pgqa-deparse (indent quoted)
"Turn the tree stored in buffer-local variable `pgqa-query-tree' into text
and replace contents of the owning buffer with it.
INDENT tells how much should the query be indented. INDENT times `tab-width'
spaces are inserted in front of each line.
If QUOTED is non-nil, the query is quoted as an SQL string."
(if (not pgqa-query-tree)
(user-error "No query has been parsed so far."))
(if (null tab-width)
(error "tab-width should not be nil"))
(let* ((state)
;; Get the start and end position from region, markers are not
;; guaranteed to exist at the moment.
(region (oref pgqa-query-tree region))
(start (elt region 0))
(end (elt region 1))
(init-col)
(init-pos)
(init-str)
(leading-whitespace nil)
(indent-estimate 0)
;; Add markers and faces only to buffers in the pgqa mode and only if
;; Emacs runs interactively.
(text-only (or (null (equal major-mode 'pgqa-mode)) noninteractive))
(query-start))
;; Markers and faces can exist if user called pgqa-parse and pgqa-deparse
;; individually.
(pgqa-delete-query-gui)
(save-excursion
(goto-char start)
(beginning-of-line)
(setq init-col (- start (point)))
(let ((line-start (point)))
(setq query-start (+ (point) init-col))
(setq init-str (buffer-substring line-start query-start))
(setq init-str-width (string-width init-str))
(if (null
;; Match means that there's at least non-whitespace character int
;; init-str.
(string-match "\\S-+" init-str))
;; The initial part of the line is only whitespace, so ignore
;; it. (We could delete only terminating whitespace and decrement
;; init-col accordingly, but it's not clear what user exactly
;; expects in such case.)
(progn
;; The query starts on the first position of the line or is
;; preceded by whitespace.
(setq leading-whitespace t)
;; Estimate the indentation while init-str-width still contains
;; tab-width characters per \t.
(setq indent-estimate (/ init-str-width tab-width))
;; If the estimate is less than half of tab-width below the next
;; position, align it to that position.
(if (> (- init-str-width (* indent-estimate tab-width))
(/ tab-width 2))
(setq indent-estimate (1+ indent-estimate)))
)
;; The first line contains non-whitespace characters, so we won't
;; adjust init-col, but still need indent-estimate for the following
;; rows. Unlike the whitespace case, do not try to match the
;; indentation of the first row by adding extra \t - the first line
;; probably shouldn't start at lower position than the next one(s).
(setq indent-estimate (/ init-str-width tab-width)))
(if (and tab-width (> tab-width 1))
;; init-str-width is the number of characters we need to delete,
;; so count each \t exacly once.
(setq init-str-width
(- init-str-width (*
(how-many "\\\t" line-start
query-start)
(- tab-width 1))))
)
)
)
;; Move query start to the line start.
(setq start (- start init-str-width))
(if (null indent)
(setq indent indent-estimate))
(if leading-whitespace
;; The leading whitespace will be removed from the first line. Only
;; indent should be applied, no additional offset.
(setq init-col 0)
;; The leading (non-whitespace) string will remain on the first line,
;; but make sure only init-col is applied to the first line (no
;; indentation).
(if (and indent (> indent 0))
(setq init-col (- init-col (* indent tab-width)))))
;; indent shouldn't be nil for the next use.
(unless indent
(setq indent 0))
;; init-pos is buffer position the deparsing starts at.
;;
;; nil value of :buffer-pos indicates that regions should not be set
;; during deparsing.
(if (null text-only)
(let* ((markers (oref pgqa-query-tree markers))
(m-start (elt markers 0)))
;; Find the beginning of the line the deparsing will start at.
(save-excursion
(goto-char m-start)
(beginning-of-line)
(setq init-pos (point)))
;; Account for indentation and additional offset representing
;; non-whitespace characters.
(setq init-pos (+
init-pos
(+ (* indent tab-width) init-col))))
)
(setq state (pgqa-init-deparse-state indent init-col
(null leading-whitespace)
init-pos))
;; The leading non-whitespace string replaces the indentation.
(if (null leading-whitespace)
(oset state result init-str))
;; XXX Should we adjust `init-col' / `init-pos' fields of the state?
(if quoted
(oset state result (concat (oref state result) "'")))
(atomic-change-group
;; The dump should also be in the atomic block, because of marker
;; changes.
;;
;; 0 is passed for indent, as the base indentation of the query is
;; contained in (oref state indent).
;;
;; if user expects SQL string, pass the context containing the last SQL
;; insertion seen. pgqa-dump-maybe-insertion can adjust it so that the
;; information is available for other nodes.
(pgqa-dump pgqa-query-tree state 0
(if quoted (make-instance 'pgqa-string-to-query-context)))
(delete-region start end)
(save-excursion
(goto-char start)
(let ((result (oref state result))
(res-end))
(if quoted
(progn
(if quoted
(setq result (concat (oref state result) "'")))
;; If the last insertion is not followed by another part of
;; the query and if the query does not end with a semicolon,
;; the query string ends with " || ''". It's easier to remove
;; this part now than to have `pgqa-dump' pay attention.
(setq res-end (string-match " || ''\\'" result))
(if res-end
(setq result (substring result 0 res-end)))))
(insert result))
;; The GUI is not appropriate outside the PGQA mode. Neither does it
;; make sense if the whole output should be an SQL string (string has
;; its own face in the PGQA mode).
(when (null (or text-only quoted))
;; Add markers and faces. (Deletion performed unconditionally above
;; as we have no information if the existing buffer contents
;; contained those objects.)
;;
;; The initial whitespace is not to be included in the node
;; markers. (That whitespace would be too hard to skip during
;; deparsing.)
(pgqa-setup-query-gui pgqa-query-tree t)
;; Add faces. (Cleanup not needed -- the query string was created
;; from scratch.)
(pgqa-set-query-faces pgqa-query-tree))
)
)
)
)
(defun pgqa-deparse-batch (&optional indent)
"Deparse query in batch mode"
(unless indent
(setq indent 0))
(setq state (pgqa-init-deparse-state indent 0 t nil))
(pgqa-dump pgqa-query-tree state 0 nil)
state)
(provide 'pgqa-parser)
pgqa-0.1/pgqa.el 0000644 0001751 0000144 00000077660 13376770703 012121 0 ustar ah users ;; Copyright (C) 2016 Antonin Houska
;;
;; This file is part of PGQA.
;;
;; PGQA 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.
;; PGQA 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 qalong
;; with PGQA. If not, see .
(require 'seq)
(require 'semantic)
;(require 'wisent)
(require 'pgqa-dump)
(require 'pgqa-node)
(require 'pgqa-parser)
(require 'pgqa-analyze)
;; pgqa-dump-raw contains macros.
(eval-when-compile
(require 'pgqa-dump-raw))
(defgroup pgqa nil
"PGQA mode user settings."
:group 'programming-group)
(defvar pgqa-log-buffer "*pgqa-log*"
"Name of buffer to which PGQA writes problems it found in SQL queries.")
;; A list of `pgqa-query-string-insertion' instances.
(defvar-local pgqa-sql-string-insertions nil)
(defvar-local pgqa-last-region nil
"A list of two markers, pointing at the start and the end of the source text
of the last processed query respectively.")
;; Markers let user interact with the query, so we refer to them as GUI.
(defvar-local pgqa-query-markers nil
"List of markers located within the current query.")
(defun pgqa-setup-query-gui (query trim)
"Add markers and text properties to query nodes.
`trim' tells that leading whitespace should not be included in node regions."
(pgqa-node-walk query 'pgqa-setup-node-gui trim))
(defun pgqa-delete-query-gui ()
"Make markers available for garbage collection."
(when pgqa-query-markers
(dolist (m pgqa-query-markers)
(set-marker m nil))
(setq pgqa-query-markers nil))
)
(defun pgqa-set-query-faces (query)
"Add faces to query nodes."
(pgqa-node-walk query 'pgqa-set-node-face nil))
(defun pgqa-reset-query-faces (query)
"Remove previously added faces from query nodes."
(pgqa-node-walk query 'pgqa-reset-node-face nil))
;; XXX Consider defcustom instead.
(defvar pgqa-mode-prefix-key "\C-c")
(defun pgqa-customize ()
(interactive)
(customize-group "pgqa" t))
(defvar pgqa-mode-prefix-map
(let ((map (make-sparse-keymap)))
(define-key map "+" '(menu-item "Customize" pgqa-customize
:visible t))
(define-key map ")" '(menu-item "Send Region" pgqa-send-region
:visible (use-region-p)))
(define-key map "{" '(menu-item "Query To String" pgqa-query-to-string
:visible t))
(define-key map "}" '(menu-item "String To Query" pgqa-string-to-query
:visible t))
(define-key map "|" '(menu-item "Create String Insertion" pgqa-create-insertion
:visible (use-region-p)))
(define-key map "<" '(menu-item "Format Query" pgqa-format-query
:visible t))
(define-key map ">" '(menu-item "Parse Query" pgqa-parse
:visible t))
map))
(defvar pgqa-mode-map
(let ((map (make-sparse-keymap)))
(define-key map [menu-bar pgqa] (cons "PGQA" pgqa-mode-prefix-map))
(define-key map pgqa-mode-prefix-key pgqa-mode-prefix-map)
map))
(defvar pgqa-mode-syntax-table
(let ((st (make-syntax-table))
(op-chars))
;; Characters that constitute SQL operators are best handled as
;; punctuation.
;;
;; TODO Modify the entries for characters that do not belong to
;; pgqa-char-terminals-non-grouped, e.g. colon - it should be punctuation
;; because it's contained in double-colon (i.e. cast operator), but is not
;; legal alone. Find out if other operators like this exist. However, if
;; it's hard for lexer to accept such "multi-character punctuations",
;; introduce special kind of token for them.
;; First, collect all the characters to be possibly contained in
;; operators.
(dolist (g pgqa-operator-groups)
(let ((ops (cdr (cdr g))))
(dolist (op ops)
(if (= (string-width op) 1)
(push (string-to-char op) op-chars)))))
(setq op-chars (append op-chars pgqa-char-terminals-non-grouped))
;; Now adjust the syntax table accordingly.
(dolist (i op-chars)
(let ((cs (char-syntax i)))
;; Do not change syntax class of terminals indispensable as opening
;; and closing parentheses - these are not likely to be used in
;; operators in valid PG expression.
(if (null (or (eq cs ?\() (eq cs ?\))))
(modify-syntax-entry i "." st))))
;; Underscore is a legal component of SQL identifiers.
(modify-syntax-entry ?_ "w" st)
;; Single quote is punctuation character in the parent table, but we need
;; it to denote strings.
(modify-syntax-entry ?' "\"" st)
;; In addition to its "punctuation" role, dash is a comment starter.
(modify-syntax-entry ?- ". 12" st)
(modify-syntax-entry ?\n "> " st)
;; Asterix should constitute for a symbol rather than punctuation. That
;; makes more sense if we want to use it as a column wildcard. However
;; this distinction only matters to syntax highlighting. As for the
;; grammar we need a special class for it anyway, see
;; get-next-query-token.
(modify-syntax-entry ?* "w" st)
;; All the other, ordinary punctuations.
(modify-syntax-entry ?= "." st)
st)
"Syntax table used while in 'pgqa-mode'.")
;; Keywords that parser does not understand (so far?), but user expect them to
;; be highlighted.
;;
;; TODO Consider if strings are safer than symbols, in terms of conflict with
;; other elisp modules.
(defvar pgqa-keywords-highlight-only
'(
BEGIN COMMENT CREATE DECLARE EXCEPTION FUNCTION IF
LANGUAGE RETURN RETURNS TABLE))
;; Turn pgqa-keywords-base list into a regular expression.
(defun pgqa-keywords ()
(list (concat "\\<"
(mapconcat 'symbol-name
(append pgqa-keyword-symbols
pgqa-keywords-highlight-only
(mapcar 'make-symbol
pgqa-keyword-operators)
)
"\\>\\|\\<")
"\\>")))
;; We add the -face suffix although the Elisp reference does not recommend
;; so. Without the prefix we'd end up with name conflicts between faces and
;; EIEIO classes.
(defface pgqa-operator-face
'((t :foreground "red1"))
"`pgqq-mode' face used to highlight SQL operators."
:group 'pgqa)
(defface pgqa-func-call-face
'((t :foreground "salmon"))
"`pgqq-mode' face used to highlight SQL functions."
:group 'pgqa)
(defface pgqa-sql-string-insertion-face
'((t :foreground "yellow"))
"`pgqq-mode' face used to highlight SQL string insertions."
:group 'pgqa)
;;;###autoload
(add-to-list 'auto-mode-alist (cons "\\.sql\\'" 'pgqa-mode))
;; TODO Make sure the funcion can also turn the mode off.
;;;###autoload
(define-derived-mode pgqa-mode
prog-mode
"PGQA"
"Major mode to parse and analyze SQL queries, with respect to the SQL \
dialect and concepts of query processing that PostgreSQL uses."
;; GNU Emacs 25 was available when the PGQA development started. Don't let
;; us accept the burden of supporting older versions.
;;
;; Raising the error during mode initialization seems relatively good
;; place. It does not prevent user from calling functions manually (and
;; possibly getting various errors), doing the check in the individual
;; functions is not appropriate either.
(if (< emacs-major-version 25)
(error "PGQA requires GNU Emacs 25 or newer"))
(setq-local font-lock-defaults
'((pgqa-keywords) nil t nil))
;; As we don't have a regular comment starter, the lexers' regular
;; expression needs to be adjusted.
(setq-local semantic-lex-comment-regex "--.*")
;; For fill-column function to work properly.
(setq-local comment-start "--"))
;; This function should be called by all features that involve multiple
;; consequent operations on the same part of the buffer. Therefore we set
;; pgqa-last-region even if the whole buffer should be processed.
;;
;; XXX Consider narrowing.
(defun pgqa-set-region ()
"Update `pgqa-last-region' according to the current region."
(let ((m-start)
(m-end))
;; When looking for the source text, marked region has the highest
;; precedence. If nothing is marked, the most recent region is used. If no
;; region was marked so far, use the whole buffer.
;;
;; Since region-beginning / region-end can return either integer or mark,
;; and since we want to avoid creating an extra mark in the latter case,
;; the easiest way to handle the change is to create a new list of markers
;; from scratch and delete the original one.
(if mark-active
(progn
(let ((m))
(setq m (region-beginning))
(if (markerp m)
(setq m-start m)
(setq m-start (make-marker))
(set-marker m-start m))
;; Make the existing marker available for garbage collection.
(when pgqa-last-region
(setq m (car pgqa-last-region))
(set-marker m nil))
(setq m (region-end))
(if (markerp m)
(setq m-end m)
(setq m-end (make-marker))
(set-marker m-end m)))
(when pgqa-last-region
(setq m (car (cdr pgqa-last-region)))
(set-marker m nil))
(deactivate-mark))
;; Mark is not active.
(if pgqa-last-region
;; The previous selection should stay intact.
(progn
(setq m-start (car pgqa-last-region))
(setq m-end (car (cdr pgqa-last-region))))
;; pgqa-last-region needs to be initialized.
(setq m-start (make-marker))
(set-marker m-start (point-min))
(setq m-end (make-marker))
(set-marker m-end (point-max))))
;; The insertion type is such that inserted text stays within the markers
;; even if they are at the beginning and the end of the buffer
;; respectively.
(set-marker-insertion-type m-start nil)
(set-marker-insertion-type m-end t)
;; Update pgqa-last-region.
(setq pgqa-last-region (list m-start m-end))))
;; Suppress compiler warning.
(declare-function pgqa-check-customizations "pgqa-dump" ())
;;;###autoload
(defun pgqa-format-query (&optional indent)
"Format SQL query that the current buffer contains. If region is active,
only the selected part of the buffer is processed.
The optional prefix argument INDENT tells how much should the query be
indented. If it's passed, then INDENT times `tab-width' spaces are inserted
in front of each line. Without it, the command tries to guess the indentation
from first position of the query."
(interactive "P")
;; The customizations do not affect parsing, but by checking early we avoid
;; wasting effort on parsing.
(pgqa-check-customizations)
;; Don't set markers during parsing.
(pgqa-parse t)
(if (> (length pgqa-sql-string-insertions) 0)
;; Make nodes aware of insertions. The insertion positions will need to
;; be adjusted during the actual formatting.
(pgqa-assign-insertions-to-nodes
pgqa-query-tree
(vector pgqa-sql-string-insertions)))
(pgqa-deparse indent nil)
(when (> (length pgqa-sql-string-insertions) 0)
;; Adjust start and end position of each insertion so it matches the
;; formatted query. Since insertions should not be used neither outside
;; pgqa-mode nor in the interactive mode, we assume that
;; pgqa-setup-query-gui has been run, so the start positions of nodes have
;; been fixed.
(pgqa-adjust-insertions pgqa-query-tree)
;; Set the insertion face.
(pgqa-set-sql-string-insertion-face pgqa-sql-string-insertions))
)
(defun pgqa-parse-query-batch ()
"Read SQL query from the standard input, parse it and write it to the
standard output."
(if (null noninteractive)
(user-error "pgqa-parse-query-batch function should only be used in
batch mode"))
(pgqa-mode)
;; The region info is currently not interesting for test. (In fact it would
;; make them more fragile.)
(setq pgqa-query-tree-print-region nil)
(let ((state))
(pgqa-parse)
(setq state
(make-instance 'pgqa-dump-raw-state
:node-start 'pgqa-node-to-lisp-start
:node-end 'pgqa-node-to-lisp-end
:result ""))
(pgqa-dump-raw pgqa-query-tree state 0)
(princ (oref state result))))
(defun pgqa-format-query-batch ()
"Read SQL query from the standard input, format it and write it to the
standard output."
(if (null noninteractive)
(user-error "pgqa-format-query-batch function should only be used in
batch mode"))
(pgqa-mode)
(let ((state))
(pgqa-check-customizations)
(pgqa-parse t)
(setq state (pgqa-deparse-batch))
(princ (oref state result))))
;; define-lex will eventually define the function, however byte compiler
;; complains if it's not defined earlier.
(defun pgqa-sql-string-lexer (start end &optional depth length))
(defvar-local pgqa-sql-string-lexer-inited nil)
(defun pgqa-set-sql-string-insertion-face (insertions)
"Add face to the existing SQL string insertions."
(dolist (insertion insertions)
(let ((m-start (oref insertion start))
(m-end (oref insertion end))
(o))
;; Create an overlay that ensures highlighting of the insertion and make
;; the insertion object aware of it for cleanup purposes.
;;
;; FRONT-ADVANCE and REAR-ADVANCE arguments correspond to the marker
;; insertion types applied in `pgqa-set-insertion-markers'.
(setq o (make-overlay m-start m-end (current-buffer) nil t))
;; Overlay is indispensable here, as opposed to text properties. The
;; point is that user might want to edit the insertion text before
;; parsing / formatting. That includes adding text at the beginning /
;; end of the insertion. Overlay seems to be the only means to ensure
;; that the added text also has the insertion face.
(overlay-put o 'font-lock-face 'pgqa-sql-string-insertion-face)
(oset insertion overlay o))
)
)
(defun pgqa-reset-sql-string-insertion-face ()
"Remove face from the existing SQL string insertions."
(dolist (insertion pgqa-sql-string-insertions)
(let ((m-start (oref insertion start))
(m-end (oref insertion end))
(o))
(setq o (oref insertion overlay))
(delete-overlay o))
)
)
(defun pgqa-delete-sql-string-insertions ()
"Remove the existing SQL string insertions."
;; Remove the face until we forget where they were set.
(pgqa-reset-sql-string-insertion-face)
;; Make the markers available for garbage collection.
(dolist (insertion pgqa-sql-string-insertions)
(let ((m-start (oref insertion start))
(m-end (oref insertion end)))
(set-marker m-start nil)
(set-marker m-end nil)))
;; Do the same for the list itself.
(setq pgqa-sql-string-insertions nil))
;; `insertions' is a single-element array that contains the actual list of
;; insertions, ordered by buffer position. Once the first insertion gets
;; processed (i.e. the first node not contained in it is reached), the list is
;; replaced with a new one that starts with the 2nd element, etc.
(defun pgqa-assign-insertions-to-nodes (query insertions)
"Assign an insertion key to each node that is contained in the insertion"
(pgqa-node-walk query 'pgqa-assign-insertion-to-node insertions))
(defun pgqa-assign-insertion-to-node (node context)
"Assign an insertion key to a single node if matching insertion exists."
(let* ((container context)
(search t)
(insertions)
(insertion)
(node-start)
(node-end)
(region)
(reg-start)
(reg-end)
(ins-start)
(ins-end))
;; The node should not have the insertion assigned so far.
(cl-assert (null (oref node insertion)))
(setq region (oref node region))
(setq node-start (elt region 0))
(setq node-end (elt region 1))
;; While searching for the next possibly useful insertion we rely on the
;; fact that consecutive calls of this function should generate
;; non-decreasing sequence of node-start values. Thus if we move to the
;; next insertion we don't have to worry that the previous one can still
;; match any node to come.
(while search
(setq insertions (aref container 0))
(if insertions
(progn
(setq insertion (car insertions))
(setq ins-end (oref insertion end))
(if (< ins-end node-start)
;; This insertion cannot affect this node as well as any
;; following. Move to the next one and make the new list
;; available for the next call(s).
(progn
(setq insertions (cdr insertions))
(aset container 0 insertions))
;; This insertion does overlap with the node, so exit the loop
;; and check.
(setq search nil)))
;; All insertions are processed, exit the loop.
(setq search nil)))
(when insertions
(setq ins-start (oref insertion start))
;; Assign the insertion to the node if the whole node is contained in
;; it.
(if (and (>= node-start ins-start) (<= node-end ins-end))
(oset node insertion insertion)))))
(defun pgqa-adjust-insertions (query)
"Update start and end positions of insertions according to
just-formatted query."
(let ((context (vector nil)))
(pgqa-node-walk query 'pgqa-adjust-insertion context)))
;; context contains the insertion key of the previous node. It's pased a as
;; single-element vector so it can be used as both input and output argument
;;
;; Like in pgqa-assign-insertion-to-node we rely on node start position to be
;; non-decreasing sequence throughout the recursion.
(defun pgqa-adjust-insertion (node context)
"Update start and end posiiton of a single insertion according
to just-formatted query."
(let ((cur (oref node insertion))
(cur-start)
(cur-end)
(prev (elt context 0))
(node-markers)
(node-start)
(node-end))
(when cur
(setq node-markers (oref node markers))
(setq node-start (elt node-markers 0))
(setq node-end (elt node-markers 1))
(setq cur-start (oref cur start))
(setq cur-end (oref cur end))
(if (and (null prev) (eq cur prev))
;; The same insertion as the previous node had. Only update the end
;; marker.
(set-marker cur-end (marker-position node-end))
(progn
;; A different insertion from that of the previous node. Set both
;; start and end position of the insertion as we don't know if the
;; next node will reference this insertion.
(set-marker cur-start (marker-position node-start))
(set-marker cur-end (marker-position node-end)))
)
)
;; Store the current insertion. This will become prev for the next node.
(aset context 0 cur))
)
(defun pgqa-string-to-query ()
"Functions written in the PL/pgSQL procedural language sometimes construct SQL
query by concatenating string constants and string variables. This function
extracts such a query from the containing string so it can be processed
further."
(interactive)
;; The feature would be difficult to use without markers and overlays. See
;; text-only variable in query-deparse.
(if (or (null (equal major-mode 'pgqa-mode)) noninteractive)
(error "pgqa-string-to-query cannot be used outside pgqa-mode or in batch mode."))
;; Cleane up the existing insertions, e.g. after having getting back to the
;; string via Undo.
(if (> (length pgqa-sql-string-insertions) 0)
(pgqa-delete-sql-string-insertions))
;; Initialize the lexer if not done yet.
(unless pgqa-sql-string-lexer-inited
(define-lex-regex-analyzer
pgqa-sql-concat-lexer
"Detect any unrecognized character."
"||"
(error "Unrecognized token"))
(define-lex-simple-regex-analyzer
pgqa-sql-concat-lexer
"Recognize SQL concatenation operator."
"||"
'concat)
(define-lex-regex-analyzer
pgqa-sql-string-lexer-error
"Detect any unrecognized character."
"."
(error "Unrecognized token"))
(define-lex
pgqa-sql-string-lexer
"Lexer responsible for tokenization of a query in the form of
SQL string."
;; Expect the query as mixture of strings and symbols,
;; separaated by the SQL concatenation operator (||).
semantic-lex-ignore-comments
semantic-lex-ignore-whitespace
semantic-lex-ignore-newline
semantic-lex-string-sql
pgqa-sql-concat-lexer
semantic-lex-symbol-or-keyword
pgqa-sql-string-lexer-error)
(semantic-lex-init)
(setq pgqa-sql-string-lexer-inited t))
;; Initialize or update pgqa-last-region.
(pgqa-set-region)
(let ((start)
(end)
(tokens)
(token-kind)
(ntokens)
(i 0)
(is-concat)
(prev-concat)
(positions)
(pos-start)
(pos-end)
(pos-query)
(str)
(str-width)
(nremoved 0)
(query ""))
;; Get the start and end positions wherever it's available.q
(let ((m-start (car pgqa-last-region))
(m-end (car (cdr pgqa-last-region))))
(setq start (marker-position m-start))
(setq end (marker-position m-end)))
(setq tokens (pgqa-sql-string-lexer start end))
(setq ntokens (length tokens))
;; Keep track of the position within the query being created. This is
;; needed to setup insertion markers.
(setq pos-query start)
(dolist (token tokens)
(setq token-kind (car token))
(setq positions (cdr token))
;; The positions need to reflect replacement of double quotations with
;; single ones.
(setq pos-start (- (car positions) nremoved))
(setq pos-end (- (cdr positions) nremoved))
;; Replace double apostrophes / quotation marks with single ones. Do not
;; touch tokens consisting of 2 apostrophes --- these represent empty
;; string and would get broken by this step.
(when (> (- pos-end pos-start) 2)
(goto-char pos-start)
(while (search-forward "''" pos-end t)
(replace-match "'" nil t)
(setq nremoved (1+ nremoved))
(setq pos-end (1- pos-end)))
)
(setq str (buffer-substring-no-properties pos-start pos-end))
;; The concatenation operator will not appear in the query, so it does
;; not affect pos-query.
(if (eq (car token) 'concat)
(setq str-width 0)
(setq str-width (- pos-end pos-start)))
;; We cannot check correctness of the query itself right now, but some
;; obviously wrong cases can be excluded immediately.
(if (and (eq i 0) (eq token-kind 'concat))
(user-error "The query string must not start with ||")
(if (and (eq i (1- ntokens)) (eq token-kind 'concat))
(user-error "The query string must not end with ||")))
;; Check if the string components are interleaved with concatenation
;; operators.
(setq is-concat (eq token-kind 'concat))
(when (and is-concat prev-concat)
(goto-char pos-start)
(user-error "Two consecutive || operators found"))
(when (and (> i 0) (null is-concat) (null prev-concat))
(goto-char pos-start)
(user-error "Missing || operator"))
(setq prev-concat is-concat)
;; Concatenate the parts, omitting the concatenation operators
;; themselves.
(unless (eq (car token) 'concat)
;; We're not interested in the apostrophes.
(when (eq token-kind 'string)
;; The apostrophes should always be there.
(cl-assert (>= (length str) 2))
(setq str (substring str 1 -1))
;; Adjust str-width accordingly.
(setq str-width (- str-width 2)))
;; Create an object representing the insertion.
(when (eq token-kind 'symbol)
(let ((insertion))
;; The start and end position needs to reflect the position of the
;; insertion in the new query, as opposed to the token positions
;; in the source string.
(setq insertion (make-instance
'pgqa-query-string-insertion
:key str
:start pos-query
:end (+ pos-query str-width)))
;; Addition to the end of the list is more expensive than addition
;; to the beginning, but the insertions must be ordered by buffer
;; position, see `pgqa-assign-insertions-to-nodes'.
(setq pgqa-sql-string-insertions
(append pgqa-sql-string-insertions (list insertion))))
)
(setq query (concat query str)))
(setq pos-query (+ pos-query str-width))
(setq i (1+ i)))
;; Finally replace the string with the contained query.
(atomic-change-group
(setq end (- end nremoved))
(delete-region start end)
(save-excursion
(goto-char start)
(insert query))
(dolist (insertion pgqa-sql-string-insertions)
;; Now that we're done with changes of the buffer text, turn integer
;; positions into markers (text replacement seems to break the
;; contained markers).
(pgqa-set-insertion-markers
insertion (oref insertion start) (oref insertion end)))
;; Set face of the insertions.
(pgqa-set-sql-string-insertion-face pgqa-sql-string-insertions))
)
)
(defun pgqa-set-insertion-markers (insertion start end)
"Add new start and end markers to insertion."
(let ((m-start)
(m-end))
(setq m-start (make-marker))
(set-marker m-start start)
(oset insertion start m-start)
(setq m-end (make-marker))
(set-marker m-end end)
(oset insertion end m-end)
;; User might want to edit the insertions before the query gets
;; parsed. The following settings should make it easier.
(set-marker-insertion-type m-start nil)
(set-marker-insertion-type m-end t))
)
(defun pgqa-query-to-string (&optional indent)
"Convert query to SQL string which can be used to execute the query from
PL/pgSQL procedure. If some parts of the query are marked as string variables
of the procedural language (i.e. insertions), these will appear separated from
other parts of the query parts by SQL concatenation operator."
(interactive "P")
;; Most of these steps have the same rationale like in pgqa-format-query.
(pgqa-check-customizations)
(pgqa-parse t)
(if (> (length pgqa-sql-string-insertions) 0)
;; Make nodes aware of insertions. The insertion positions will need to
;; be adjusted during the actual formatting.
(pgqa-assign-insertions-to-nodes
pgqa-query-tree
(vector pgqa-sql-string-insertions)))
;; Turn the query into a string and quote it so it can be treated as an SQL
;; string.
(pgqa-deparse indent t)
;; Cleanup.
(pgqa-delete-sql-string-insertions))
(defun pgqa-create-insertion (start end)
"Mark the part of the query within region as an insertion."
(interactive "r")
(let ((ins-start start)
(ins-end end)
(context)
(matched)
(nmatched)
(ins-node)
(markers)
(node-start)
(node-end)
(insertion)
(ins-new-key)
(insertion-new)
(insertions-reverse)
(pushed))
;; Mark should now contain the new insertion, not the query. Remember and
;; and deactivate the mark so that parser does not think that the region
;; contains the query to be parsed.
(deactivate-mark)
;; Make sure we have up-to-date query tree.
(pgqa-parse-common nil)
;; The `matched' list is for output.
(setq context (vector ins-start ins-end matched))
(pgqa-node-walk pgqa-query-tree 'pgqa-find-insertion-candidates
context)
;; Insertion can only be created if exactly one node matches.
(setq matched (elt context 2))
(setq nmatched (length matched))
(if (= nmatched 0)
(user-error
"The region contains no potential insertion")
(if (> nmatched 1)
(user-error
"The region contains more than one potential insertion"))
)
(setq ins-node (car matched))
;; Make sure that no existing insertion overlaps with the new one.
(setq markers (oref ins-node markers))
(setq node-start (elt markers 0))
(setq node-end (elt markers 1))
(dolist (insertion pgqa-sql-string-insertions)
(let ((ins-start (oref insertion start))
(ins-end (oref insertion end)))
(if (null
(or
(< node-end ins-start)
(> node-start ins-end)))
(user-error "The new insertion overlaps with existing one."))
)
;; Since adding element to the list head is easier than adding it to the
;; end, use this iteration to construct a list ordered in the reverse
;; order. Thus we can also use `push' when adding the new insertion to
;; the list.
(push insertion insertions-reverse))
;; Read insertion key and check it.
(setq ins-new-key (read-from-minibuffer "Insertion key: "))
(if (string-match "\\s-" ins-new-key)
(user-error "The insertion key must not contain whitespace characters"))
;; Replace the original text with the key.
(atomic-change-group
;; Temporarily change the marker insertion type so that it the inserted
;; text does not move it ahead.
(cl-assert (marker-insertion-type node-start))
(set-marker-insertion-type node-start nil)
(delete-region node-start node-end)
(save-excursion
(goto-char node-start)
(insert ins-new-key))
;; Restore the original insertion type.
(set-marker-insertion-type node-start t))
;; Create the new insertion.
(setq insertion-new (make-instance
'pgqa-query-string-insertion
:key ins-new-key))
;; Assign it markers ...
(pgqa-set-insertion-markers insertion-new
node-start
(+ node-start (string-width ins-new-key)))
;; ... and face.
(pgqa-set-sql-string-insertion-face (list insertion-new))
;; Add it to the list of existing insertions. Make sure the insertion is
;; added to the correct position in the list.
(setq pgqa-sql-string-insertions nil)
(dolist (insertion insertions-reverse)
(let ((ins-end (oref insertion end))
(ins-start-new (oref insertion-new start)))
;; Given that ins-end is descending, the new insertion precedes the
;; existing one if it's at higher position.
(when (> ins-start-new ins-end)
(push insertion-new pgqa-sql-string-insertions)
(setq pushed t)))
;; Push the existing insertion.
(push insertion pgqa-sql-string-insertions))
;; If the new insertion hasn't been pushed so far, it must be in front of
;; all the existing ones or it's the first one.
(when (null pushed)
(when (> (length insertions-reverse) 0)
(setq insertion (car pgqa-sql-string-insertions))
(cl-assert (< (oref insertion-new end) (oref insertion start))))
(push insertion-new pgqa-sql-string-insertions))
)
)
(defun pgqa-find-insertion-candidates (node context)
"Find nodes in the region that can be turned into SQL string insertion"
(let* ((reg-start (elt context 0))
(reg-end (elt context 1))
(output (elt context 2))
(markers (oref node markers))
(node-start (elt markers 0))
(node-end (elt markers 1)))
;; Does the node fit into the region?
(if (and (>= node-start reg-start) (<= node-end reg-end))
;; Currently we create insertion for table name, column
;; reference, numeric literal and string literal.
(let ((cn (eieio-object-class-name node)))
(when (or
(eq cn 'pgqa-obj)
(eq cn 'pgqa-number)
(eq cn 'pgqa-string))
(push node output)
(aset context 2 output)))
)
)
)
(defcustom pgqa-host "localhost"
"Host name to which `pgqa-send-region' function connects."
:type 'string)
(defcustom pgqa-port "5432"
"TCP port to which `pgqa-send-region' function connects."
:type 'string)
(defcustom pgqa-database "postgres"
"Name of database to which `pgqa-send-region' function connects."
:type 'string)
(defcustom pgqa-role "postgres"
"Role that `pgqa-send-region' function uses to connect to database."
:type 'string)
(defcustom pgqa-psql-path "psql"
"Path to psql client application used by `pgqa-send-region' function."
:type 'string)
(defcustom pgqa-psql-output "*pgqa-psql-output*"
"Name of buffer to which `pgqa-send-region' writes the server response."
:type 'string)
(defun pgqa-send-region (start end)
"Send region to PostgreSQL server, connection to which is specified using
`pgqa-database' and `pgqa-role' customization variebles. The server response
is written to the buffer whose name is in `pgqa-psql-output'."
(interactive "r")
(get-buffer-create pgqa-psql-output)
;; Make sure the next message is written at the end of the buffer. XXX
;; Shouldn't the buffer be read-only?
(with-current-buffer pgqa-psql-output
(goto-char (point-max)))
(call-process-region start end pgqa-psql-path nil pgqa-psql-output nil
"-U" pgqa-role "-h" pgqa-host "-p" pgqa-port
pgqa-database)
(deactivate-mark)
;; User should not need to scroll down manually.
(with-current-buffer pgqa-psql-output
(let ((w (get-buffer-window)))
;; Make sure the buffer is displayed.
(unless w
(setq w (next-window))
(set-window-buffer w pgqa-psql-output))
(select-window w)
(goto-char (point-max))))
)
(provide 'pgqa)
pgqa-0.1/pgqa-pkg.el 0000644 0001751 0000144 00000000115 13376770703 012655 0 ustar ah users (define-package "pgqa" "0.1" "Emacs mode to parse and analyze SQL queries.")