diff --git a/LICENSE b/LICENSE deleted file mode 100644 --- a/LICENSE +++ /dev/null @@ -1,340 +0,0 @@ - GNU GENERAL PUBLIC LICENSE - Version 2, June 1991 - - Copyright (C) 1989, 1991 Free Software Foundation, Inc. - 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - Everyone is permitted to copy and distribute verbatim copies - of this license document, but changing it is not allowed. - - Preamble - - The licenses for most software are designed to take away your -freedom to share and change it. By contrast, the GNU General Public -License is intended to guarantee your freedom to share and change free -software--to make sure the software is free for all its users. This -General Public License applies to most of the Free Software -Foundation's software and to any other program whose authors commit to -using it. (Some other Free Software Foundation software is covered by -the GNU Library General Public License instead.) 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 -this service 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 make restrictions that forbid -anyone to deny you these rights or to ask you to surrender the rights. -These restrictions translate to certain responsibilities for you if you -distribute copies of the software, or if you modify it. - - For example, if you distribute copies of such a program, whether -gratis or for a fee, you must give the recipients all the rights that -you have. 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. - - We protect your rights with two steps: (1) copyright the software, and -(2) offer you this license which gives you legal permission to copy, -distribute and/or modify the software. - - Also, for each author's protection and ours, we want to make certain -that everyone understands that there is no warranty for this free -software. If the software is modified by someone else and passed on, we -want its recipients to know that what they have is not the original, so -that any problems introduced by others will not reflect on the original -authors' reputations. - - Finally, any free program is threatened constantly by software -patents. We wish to avoid the danger that redistributors of a free -program will individually obtain patent licenses, in effect making the -program proprietary. To prevent this, we have made it clear that any -patent must be licensed for everyone's free use or not licensed at all. - - The precise terms and conditions for copying, distribution and -modification follow. - - GNU GENERAL PUBLIC LICENSE - TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION - - 0. This License applies to any program or other work which contains -a notice placed by the copyright holder saying it may be distributed -under the terms of this General Public License. The "Program", below, -refers to any such program or work, and a "work based on the Program" -means either the Program or any derivative work under copyright law: -that is to say, a work containing the Program or a portion of it, -either verbatim or with modifications and/or translated into another -language. (Hereinafter, translation is included without limitation in -the term "modification".) Each licensee is addressed as "you". - -Activities other than copying, distribution and modification are not -covered by this License; they are outside its scope. The act of -running the Program is not restricted, and the output from the Program -is covered only if its contents constitute a work based on the -Program (independent of having been made by running the Program). -Whether that is true depends on what the Program does. - - 1. You may copy and distribute 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 and disclaimer of warranty; keep intact all the -notices that refer to this License and to the absence of any warranty; -and give any other recipients of the Program a copy of this License -along with the Program. - -You may charge a fee for the physical act of transferring a copy, and -you may at your option offer warranty protection in exchange for a fee. - - 2. You may modify your copy or copies of the Program or any portion -of it, thus forming a work based on the Program, and copy and -distribute such modifications or work under the terms of Section 1 -above, provided that you also meet all of these conditions: - - a) You must cause the modified files to carry prominent notices - stating that you changed the files and the date of any change. - - b) You must cause any work that you distribute or publish, that in - whole or in part contains or is derived from the Program or any - part thereof, to be licensed as a whole at no charge to all third - parties under the terms of this License. - - c) If the modified program normally reads commands interactively - when run, you must cause it, when started running for such - interactive use in the most ordinary way, to print or display an - announcement including an appropriate copyright notice and a - notice that there is no warranty (or else, saying that you provide - a warranty) and that users may redistribute the program under - these conditions, and telling the user how to view a copy of this - License. (Exception: if the Program itself is interactive but - does not normally print such an announcement, your work based on - the Program is not required to print an announcement.) - -These requirements apply to the modified work as a whole. If -identifiable sections of that work are not derived from the Program, -and can be reasonably considered independent and separate works in -themselves, then this License, and its terms, do not apply to those -sections when you distribute them as separate works. But when you -distribute the same sections as part of a whole which is a work based -on the Program, the distribution of the whole must be on the terms of -this License, whose permissions for other licensees extend to the -entire whole, and thus to each and every part regardless of who wrote it. - -Thus, it is not the intent of this section to claim rights or contest -your rights to work written entirely by you; rather, the intent is to -exercise the right to control the distribution of derivative or -collective works based on the Program. - -In addition, mere aggregation of another work not based on the Program -with the Program (or with a work based on the Program) on a volume of -a storage or distribution medium does not bring the other work under -the scope of this License. - - 3. You may copy and distribute the Program (or a work based on it, -under Section 2) in object code or executable form under the terms of -Sections 1 and 2 above provided that you also do one of the following: - - a) Accompany it with the complete corresponding machine-readable - source code, which must be distributed under the terms of Sections - 1 and 2 above on a medium customarily used for software interchange; or, - - b) Accompany it with a written offer, valid for at least three - years, to give any third party, for a charge no more than your - cost of physically performing source distribution, a complete - machine-readable copy of the corresponding source code, to be - distributed under the terms of Sections 1 and 2 above on a medium - customarily used for software interchange; or, - - c) Accompany it with the information you received as to the offer - to distribute corresponding source code. (This alternative is - allowed only for noncommercial distribution and only if you - received the program in object code or executable form with such - an offer, in accord with Subsection b above.) - -The source code for a work means the preferred form of the work for -making modifications to it. For an executable work, complete source -code means all the source code for all modules it contains, plus any -associated interface definition files, plus the scripts used to -control compilation and installation of the executable. However, as a -special exception, the source code distributed need not include -anything that is normally distributed (in either source or binary -form) with the major components (compiler, kernel, and so on) of the -operating system on which the executable runs, unless that component -itself accompanies the executable. - -If distribution of executable or object code is made by offering -access to copy from a designated place, then offering equivalent -access to copy the source code from the same place counts as -distribution of the source code, even though third parties are not -compelled to copy the source along with the object code. - - 4. You may not copy, modify, sublicense, or distribute the Program -except as expressly provided under this License. Any attempt -otherwise to copy, modify, sublicense or distribute the Program is -void, and will automatically terminate your rights under this License. -However, parties who have received copies, or rights, from you under -this License will not have their licenses terminated so long as such -parties remain in full compliance. - - 5. You are not required to accept this License, since you have not -signed it. However, nothing else grants you permission to modify or -distribute the Program or its derivative works. These actions are -prohibited by law if you do not accept this License. Therefore, by -modifying or distributing the Program (or any work based on the -Program), you indicate your acceptance of this License to do so, and -all its terms and conditions for copying, distributing or modifying -the Program or works based on it. - - 6. Each time you redistribute the Program (or any work based on the -Program), the recipient automatically receives a license from the -original licensor to copy, distribute or modify the Program subject to -these terms and conditions. You may not impose any further -restrictions on the recipients' exercise of the rights granted herein. -You are not responsible for enforcing compliance by third parties to -this License. - - 7. If, as a consequence of a court judgment or allegation of patent -infringement or for any other reason (not limited to patent issues), -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 -distribute so as to satisfy simultaneously your obligations under this -License and any other pertinent obligations, then as a consequence you -may not distribute the Program at all. For example, if a patent -license would not permit royalty-free redistribution of the Program by -all those who receive copies directly or indirectly through you, then -the only way you could satisfy both it and this License would be to -refrain entirely from distribution of the Program. - -If any portion of this section is held invalid or unenforceable under -any particular circumstance, the balance of the section is intended to -apply and the section as a whole is intended to apply in other -circumstances. - -It is not the purpose of this section to induce you to infringe any -patents or other property right claims or to contest validity of any -such claims; this section has the sole purpose of protecting the -integrity of the free software distribution system, which is -implemented by public license practices. Many people have made -generous contributions to the wide range of software distributed -through that system in reliance on consistent application of that -system; it is up to the author/donor to decide if he or she is willing -to distribute software through any other system and a licensee cannot -impose that choice. - -This section is intended to make thoroughly clear what is believed to -be a consequence of the rest of this License. - - 8. If the distribution and/or use of the Program is restricted in -certain countries either by patents or by copyrighted interfaces, the -original copyright holder who places the Program under this License -may add an explicit geographical distribution limitation excluding -those countries, so that distribution is permitted only in or among -countries not thus excluded. In such case, this License incorporates -the limitation as if written in the body of this License. - - 9. The Free Software Foundation may publish revised and/or new versions -of the 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 a version number of this License which applies to it and "any -later version", you have the option of following the terms and conditions -either of that version or of any later version published by the Free -Software Foundation. If the Program does not specify a version number of -this License, you may choose any version ever published by the Free Software -Foundation. - - 10. If you wish to incorporate parts of the Program into other free -programs whose distribution conditions are different, write to the author -to ask for permission. For software which is copyrighted by the Free -Software Foundation, write to the Free Software Foundation; we sometimes -make exceptions for this. Our decision will be guided by the two goals -of preserving the free status of all derivatives of our free software and -of promoting the sharing and reuse of software generally. - - NO WARRANTY - - 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, 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. - - 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING -WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR -REDISTRIBUTE 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. - - 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 -convey 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 2 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA - - -Also add information on how to contact you by electronic and paper mail. - -If the program is interactive, make it output a short notice like this -when it starts in an interactive mode: - - Gnomovision version 69, Copyright (C) year name of author - Gnomovision 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, the commands you use may -be called something other than `show w' and `show c'; they could even be -mouse-clicks or menu items--whatever suits your program. - -You should also get your employer (if you work as a programmer) or your -school, if any, to sign a "copyright disclaimer" for the program, if -necessary. Here is a sample; alter the names: - - Yoyodyne, Inc., hereby disclaims all copyright interest in the program - `Gnomovision' (which makes passes at compilers) written by James Hacker. - - , 1 April 1989 - Ty Coon, President of Vice - -This 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 Library General -Public License instead of this License. diff --git a/database/array.hoo b/database/array.hoo new file mode 100644 Binary files /dev/null and b/database/array.hoo differ diff --git a/database/base.hoo b/database/base.hoo new file mode 100644 Binary files /dev/null and b/database/base.hoo differ diff --git a/database/bytestring.hoo b/database/bytestring.hoo new file mode 100644 Binary files /dev/null and b/database/bytestring.hoo differ diff --git a/database/cabal.hoo b/database/cabal.hoo new file mode 100644 Binary files /dev/null and b/database/cabal.hoo differ diff --git a/database/containers.hoo b/database/containers.hoo new file mode 100644 Binary files /dev/null and b/database/containers.hoo differ diff --git a/database/default.hoo b/database/default.hoo new file mode 100644 # file too large to diff: database/default.hoo diff --git a/database/directory.hoo b/database/directory.hoo new file mode 100644 Binary files /dev/null and b/database/directory.hoo differ diff --git a/database/filepath.hoo b/database/filepath.hoo new file mode 100644 Binary files /dev/null and b/database/filepath.hoo differ diff --git a/database/ghc.hoo b/database/ghc.hoo new file mode 100644 Binary files /dev/null and b/database/ghc.hoo differ diff --git a/database/hackage.hoo b/database/hackage.hoo new file mode 100644 Binary files /dev/null and b/database/hackage.hoo differ diff --git a/database/haskell-src.hoo b/database/haskell-src.hoo new file mode 100644 Binary files /dev/null and b/database/haskell-src.hoo differ diff --git a/database/hunit.hoo b/database/hunit.hoo new file mode 100644 Binary files /dev/null and b/database/hunit.hoo differ diff --git a/database/keyword.hoo b/database/keyword.hoo new file mode 100644 Binary files /dev/null and b/database/keyword.hoo differ diff --git a/database/mtl.hoo b/database/mtl.hoo new file mode 100644 Binary files /dev/null and b/database/mtl.hoo differ diff --git a/database/parallel.hoo b/database/parallel.hoo new file mode 100644 Binary files /dev/null and b/database/parallel.hoo differ diff --git a/database/parsec.hoo b/database/parsec.hoo new file mode 100644 Binary files /dev/null and b/database/parsec.hoo differ diff --git a/database/pretty.hoo b/database/pretty.hoo new file mode 100644 Binary files /dev/null and b/database/pretty.hoo differ diff --git a/database/process.hoo b/database/process.hoo new file mode 100644 Binary files /dev/null and b/database/process.hoo differ diff --git a/database/quickcheck.hoo b/database/quickcheck.hoo new file mode 100644 Binary files /dev/null and b/database/quickcheck.hoo differ diff --git a/database/random.hoo b/database/random.hoo new file mode 100644 Binary files /dev/null and b/database/random.hoo differ diff --git a/database/stm.hoo b/database/stm.hoo new file mode 100644 Binary files /dev/null and b/database/stm.hoo differ diff --git a/database/template-haskell.hoo b/database/template-haskell.hoo new file mode 100644 Binary files /dev/null and b/database/template-haskell.hoo differ diff --git a/database/time.hoo b/database/time.hoo new file mode 100644 Binary files /dev/null and b/database/time.hoo differ diff --git a/database/xhtml.hoo b/database/xhtml.hoo new file mode 100644 Binary files /dev/null and b/database/xhtml.hoo differ diff --git a/default.hoo b/default.hoo deleted file mode 100644 # file too large to diff: default.hoo diff --git a/docs/LICENSE b/docs/LICENSE new file mode 100644 --- /dev/null +++ b/docs/LICENSE @@ -0,0 +1,340 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc. + 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Library General Public License instead.) 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 +this service 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 make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. 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. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute 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 and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +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 +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the 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 a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, 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. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE 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. + + 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 +convey 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 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision 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, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This 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 Library General +Public License instead of this License. diff --git a/hoogle.cabal b/hoogle.cabal --- a/hoogle.cabal +++ b/hoogle.cabal @@ -1,9 +1,9 @@ -cabal-version: >= 1.1.4 +cabal-version: >= 1.2 build-type: Simple name: hoogle -version: 4.0.0.3 +version: 4.0.0.5 license: GPL -license-file: LICENSE +license-file: docs/LICENSE category: Development author: Neil Mitchell maintainer: Neil Mitchell @@ -15,85 +15,119 @@ or by approximate type signature. homepage: http://www.haskell.org/hoogle/ stability: Beta -build-depends: base, parsec, filepath, directory, process, safe, containers, uniplate, mtl, array extra-source-files: README.txt -data-files: default.hoo +data-dir: database +data-files: + array.hoo + base.hoo + bytestring.hoo + cabal.hoo + containers.hoo + default.hoo + directory.hoo + filepath.hoo + ghc.hoo + hackage.hoo + haskell-src.hoo + hunit.hoo + keyword.hoo + mtl.hoo + parallel.hoo + parsec.hoo + pretty.hoo + process.hoo + quickcheck.hoo + random.hoo + stm.hoo + template-haskell.hoo + time.hoo + xhtml.hoo -executable: hoogle -main-is: Main.hs -hs-source-dirs: src -other-modules: - CmdLine.Action - CmdLine.All - CmdLine.Files - CmdLine.Flag - CmdLine.Query - CmdLine.Search - CmdLine.Test - Data.Binary.Defer - Data.Binary.Defer.Array - Data.Binary.Defer.Chunk - Data.Binary.Defer.Class - Data.Binary.Defer.Graph - Data.Binary.Defer.Index - Data.Binary.Defer.Map - Data.Binary.Defer.Monad - Data.Binary.Defer.Trie - Data.Binary.Defer.Vector - Data.Binary.Raw - Data.Heap - Data.Key - Data.Range - Data.TagStr - Data.TypeMap - General.CGI - General.Code - General.Glob - General.TextUtil - General.Util - Hoogle.All - Hoogle.DataBase.Aliases - Hoogle.DataBase.All - Hoogle.DataBase.Instances - Hoogle.DataBase.Items - Hoogle.DataBase.NameSearch - Hoogle.DataBase.Serialise - Hoogle.DataBase.Suggest - Hoogle.DataBase.Type - Hoogle.DataBase.TypeSearch.All - Hoogle.DataBase.TypeSearch.Binding - Hoogle.DataBase.TypeSearch.Cost - Hoogle.DataBase.TypeSearch.EntryInfo - Hoogle.DataBase.TypeSearch.Graph - Hoogle.DataBase.TypeSearch.Graphs - Hoogle.DataBase.TypeSearch.Result - Hoogle.DataBase.TypeSearch.TypeScore - Hoogle.Item.All - Hoogle.Item.Haddock - Hoogle.Item.Item - Hoogle.Operations.All - Hoogle.Operations.Convert - Hoogle.Operations.Rank - Hoogle.Operations.RankSolve - Hoogle.Query.All - Hoogle.Query.Parser - Hoogle.Query.Render - Hoogle.Query.Suggest - Hoogle.Query.Type - Hoogle.Search.All - Hoogle.Search.Result - Hoogle.Search.Results - Hoogle.TextBase.All - Hoogle.TextBase.Parser - Hoogle.TextBase.Type - Hoogle.TypeSig.All - Hoogle.TypeSig.Parser - Hoogle.TypeSig.Type - Test.All - Test.General - Test.Parse_Query - Test.Parse_TextBase - Test.Parse_TypeSig - Web.Action - Web.All - Web.Page +flag splitBase + Description: Choose the new smaller, split-up base package. + +executable hoogle + build-depends: parsec, filepath, safe, uniplate, mtl, time + if flag(splitBase) + build-depends: base >= 3, directory, process, containers, array, bytestring + else + build-depends: base < 3 + + main-is: Main.hs + hs-source-dirs: src + other-modules: + CmdLine.Action + CmdLine.All + CmdLine.Files + CmdLine.Flag + CmdLine.Query + CmdLine.Search + CmdLine.Test + Data.Binary.Defer + Data.Binary.Defer.Array + Data.Binary.Defer.Class + Data.Binary.Defer.Index + Data.Binary.Defer.Map + Data.Binary.Defer.Monad + Data.Binary.Defer.Trie + Data.Binary.Defer.Vector + Data.Binary.Raw + Data.Heap + Data.Key + Data.Range + Data.TagStr + Data.TypeMap + General.CGI + General.Code + General.Glob + General.TextUtil + General.Util + Hoogle.All + Hoogle.DataBase.Aliases + Hoogle.DataBase.All + Hoogle.DataBase.Instances + Hoogle.DataBase.Items + Hoogle.DataBase.NameSearch + Hoogle.DataBase.Serialise + Hoogle.DataBase.Suggest + Hoogle.DataBase.Type + Hoogle.DataBase.TypeSearch.All + Hoogle.DataBase.TypeSearch.Binding + Hoogle.DataBase.TypeSearch.Cost + Hoogle.DataBase.TypeSearch.EntryInfo + Hoogle.DataBase.TypeSearch.Graph + Hoogle.DataBase.TypeSearch.Graphs + Hoogle.DataBase.TypeSearch.Result + Hoogle.DataBase.TypeSearch.TypeScore + Hoogle.Item.All + Hoogle.Item.Haddock + Hoogle.Item.Item + Hoogle.Item.URL + Hoogle.Operations.All + Hoogle.Operations.Combine + Hoogle.Operations.Convert + Hoogle.Operations.Rank + Hoogle.Operations.RankSolve + Hoogle.Query.All + Hoogle.Query.Parser + Hoogle.Query.Render + Hoogle.Query.Suggest + Hoogle.Query.Type + Hoogle.Search.All + Hoogle.Search.Result + Hoogle.Search.Results + Hoogle.TextBase.All + Hoogle.TextBase.Parser + Hoogle.TextBase.Type + Hoogle.TypeSig.All + Hoogle.TypeSig.Parser + Hoogle.TypeSig.Type + Test.All + Test.General + Test.Parse_Query + Test.Parse_TextBase + Test.Parse_TypeSig + Web.Action + Web.All + Web.Page + Web.Text diff --git a/src/CmdLine/Action.hs b/src/CmdLine/Action.hs --- a/src/CmdLine/Action.hs +++ b/src/CmdLine/Action.hs @@ -56,6 +56,18 @@ mapM_ (actionConvert q) [x | Convert x <- queryFlags q] +actionCmdLine q | Combine{} `elemEnum` queryFlags q = do + -- TODO: Work around a bug in CmdLine.Flags, try /merge=t1;t2 + -- and you get [t1,t1,t2,t2] + let files = nub [x | Combine x <- queryFlags q] + outfile = headDef "default.hoo" [x | Output x <- queryFlags q] + putStrLn $ "Combining " ++ show (length files) ++ " databases" + combine files outfile + when (Dump{} `elemEnum` queryFlags q) $ do + putStrLn "" + actionDump q outfile + + actionCmdLine q | Dump{} `elemEnum` queryFlags q = do dbs <- getDataBaseFiles (queryFlags q) (fromRight $ query q) mapM_ (actionDump q) dbs @@ -84,7 +96,8 @@ actionConvert q infile = do let outfile = headDef (replaceExtension infile "hoo") [x | Output x <- queryFlags q] putStrLn $ "Converting " ++ infile - convert (Debug `elem` queryFlags q) infile outfile + deps <- getDataBaseFilesNoDefault (queryFlags q) (fromRight $ query q) + convert (Debug `elem` queryFlags q) deps infile outfile putStrLn $ "Written " ++ outfile when (Dump{} `elemEnum` queryFlags q) $ do @@ -95,5 +108,5 @@ actionTest :: CmdQuery -> FilePath -> IO () actionTest q infile = do - outfile <- actionConvert q infile + outfile <- actionConvert q{queryFlags = Debug : queryFlags q} infile testFile infile outfile diff --git a/src/CmdLine/Files.hs b/src/CmdLine/Files.hs --- a/src/CmdLine/Files.hs +++ b/src/CmdLine/Files.hs @@ -1,5 +1,5 @@ -module CmdLine.Files(getDataBaseFiles) where +module CmdLine.Files(getDataBaseFiles, getDataBaseFilesNoDefault) where import CmdLine.Flag import General.Glob @@ -12,16 +12,23 @@ -- otherwise use the CmdFlag and any +package query flags getDataBaseFiles :: [CmdFlag] -> Query -> IO [FilePath] getDataBaseFiles flags q = do + xs <- getDataBaseFilesNoDefault flags q + if null xs + then liftM (:[]) $ resolve flags "default" + else return xs + + +getDataBaseFilesNoDefault :: [CmdFlag] -> Query -> IO [FilePath] +getDataBaseFilesNoDefault flags q = do let dataFil = [x | DataFile x <- flags] plusPkg = [x | PlusPackage x <- scope q] - if null dataFil && null plusPkg then - liftM (:[]) $ resolve "default" - else do - rs <- mapM resolve plusPkg - return $ dataFil ++ rs - where - inc = [x | Include x <- flags] - resolve x = do - dataDir <- getDataDir - [x] <- globFile (inc++[dataDir]) ["hoo"] x - return x + rs <- mapM (resolve flags) plusPkg + return $ dataFil ++ rs + + +resolve :: [CmdFlag] -> String -> IO FilePath +resolve flags x = do + let inc = [x | Include x <- flags] + dataDir <- getDataDir + [x] <- globFile (inc++[dataDir]) ["hoo"] x + return x diff --git a/src/CmdLine/Flag.hs b/src/CmdLine/Flag.hs --- a/src/CmdLine/Flag.hs +++ b/src/CmdLine/Flag.hs @@ -34,12 +34,14 @@ | Include FilePath -- ^ Include directory | TestFile FilePath -- ^ Run tests in a file | Rank FilePath -- ^ Generate rankings + | Combine FilePath -- ^ Merge a set of databases + | Mode String -- ^ Web modes deriving (Show,Eq {-! Enum !-} ) -- | In which circumstances are you allowed to pass this command data Permission = PWebArgs | PWebQuery | PCmdLine | PMultiple - deriving Eq + deriving (Show,Eq) data Argument = ArgNone CmdFlag | ArgBool (Bool -> CmdFlag) @@ -88,6 +90,8 @@ ,f (ArgDir Include) ["i","include"] [PCmdLine,PMultiple] "Include directories" ,f (ArgFileIn TestFile ["txt"]) ["testfile"] [PCmdLine,PMultiple] "Run tests from a file" ,f (ArgFileIn Rank ["txt"]) ["rank"] [PCmdLine,PMultiple] "Generate ranking scores" + ,f (ArgFileIn Combine ["hoo"]) ["combine"] [PCmdLine,PMultiple] "Combine multiple databases" + ,f (ArgStr Mode) ["mode"] [PCmdLine,PWebArgs] "Web mode" ] where f = FlagInfo @@ -147,6 +151,7 @@ -- Parsing Flags -- TODO: check no flag is specified twice +-- TODO: Fix a bug, try /merge=t1;t2 and you get [t1,t1,t2,t2] parseFlags :: Permission -> [(String,String)] -> IO ([CmdFlag],[String]) parseFlags perm xs = do let args = concatMap (parseFlag perm) xs @@ -207,7 +212,7 @@ -------------------------------------------------------- -- DERIVES GENERATED CODE -- DO NOT MODIFY BELOW THIS LINE --- CHECKSUM: 780144949 +-- CHECKSUM: 1401092643 instance Enum CmdFlag where toEnum 0 = Version{} @@ -227,6 +232,7 @@ toEnum 14 = Include{} toEnum 15 = TestFile{} toEnum 16 = Rank{} + toEnum 17 = Combine{} toEnum n = error ((++) "toEnum " ((++) (show n) ", not defined for CmdFlag")) fromEnum (Version {}) = 0 fromEnum (Web {}) = 1 @@ -245,3 +251,4 @@ fromEnum (Include {}) = 14 fromEnum (TestFile {}) = 15 fromEnum (Rank {}) = 16 + fromEnum (Combine {}) = 17 diff --git a/src/CmdLine/Query.hs b/src/CmdLine/Query.hs --- a/src/CmdLine/Query.hs +++ b/src/CmdLine/Query.hs @@ -51,7 +51,7 @@ (flags2,bad2) <- flagsWebQuery $ queryArgs res return $ CmdQuery True str (Right res) (flags2++flags1) (bad2++bad1) where - (q,notq) = partition ((==) "q" . fst) xs + (q,notq) = partition ((`elem` ["q","hoogle"]) . fst) xs str = unwords $ map snd q diff --git a/src/CmdLine/Search.hs b/src/CmdLine/Search.hs --- a/src/CmdLine/Search.hs +++ b/src/CmdLine/Search.hs @@ -35,9 +35,12 @@ if null res then putStrLn "No results found" else if Info `elemEnum` flags then do - putStrLn $ f $ renderResult $ head res - putStrLn "" - putStrLn $ showTag $ renderHaddock $ entryDocs $ fromLink $ resultEntry $ head res + let ent = fromLink $ resultEntry $ head res + pkg = fromLink $ entryPackage ent + putStrLns 2 $ f $ renderResult $ head res + putStrLns 2 $ showTag $ renderHaddock $ entryDocs ent + putStrLn $ "From package " ++ packageName pkg ++ ", version " ++ packageVersion pkg + putStrLns 1 $ entryURL ent else putStr $ unlines $ map (f . renderResult) res where @@ -52,3 +55,11 @@ f (m,r,v) = maybe "" (\m -> showModule m ++ " ") m ++ showTag r ++ (if verbose then " -- " ++ v else "") + + +-- Put out a string with some blank links following +-- Do not put out the blank lines if no text output +putStrLns :: Int -> String -> IO () +putStrLns n xs = when (xs /= "") $ do + putStr xs + putStr $ replicate n '\n' diff --git a/src/CmdLine/Test.hs b/src/CmdLine/Test.hs --- a/src/CmdLine/Test.hs +++ b/src/CmdLine/Test.hs @@ -20,7 +20,10 @@ putStrLn $ show (length bad) ++ " tests failed" --- LineNo Query Results +-- LineNo Query NoResults YesResults +-- NoResults is a list of results that are not allowed to appear +-- YesResults are sets of results, which must be in order, and within a set must +-- have the same Score data Test = Test Int String Query [String] [[String]] deriving Show diff --git a/src/Data/Binary/Defer/Chunk.hs b/src/Data/Binary/Defer/Chunk.hs deleted file mode 100644 --- a/src/Data/Binary/Defer/Chunk.hs +++ /dev/null @@ -1,51 +0,0 @@ - -module Data.Binary.Defer.Chunk( - Chunk, newChunk, - lookupChunk - ) where - -import Control.Monad -import Data.Binary.Defer -import Data.Binary.Defer.Array -import Data.Range - - -chunkSize = 100 :: Int - -newtype Chunk a = Chunk (Array (Vector a)) -newtype Vector a = Vector {unVector :: [a]} - - -newChunk :: [a] -> Chunk a -newChunk = Chunk . array . f - where - f [] = [] - f xs = Vector a : f b - where (a,b) = splitAt chunkSize xs - - -lookupChunk :: Range -> Chunk a -> [a] -lookupChunk r (Chunk xs) = - drop m $ f d (count + m) - where - (start,count) = (rangeStart r, rangeCount r) - (d,m) = start `divMod` chunkSize - - f i n | n == 0 = [] - | n < chunkSize = take n $ unVector $ xs ! i - | otherwise = unVector (xs ! i) ++ f (i+1) (n-chunkSize) - - -instance BinaryDefer a => BinaryDefer (Chunk a) where - put (Chunk a) = put a - get = get1 Chunk - -instance BinaryDefer a => BinaryDefer (Vector a) where - put (Vector xs) = putInt (length xs) >> mapM_ put xs - get = do - i <- getInt - liftM Vector $ replicateM i get - -instance Show a => Show (Chunk a) where - show (Chunk xs) = unlines $ zipWith f [0..] $ concatMap unVector $ elems xs - where f i x = show i ++ " = " ++ show x diff --git a/src/Data/Binary/Defer/Class.hs b/src/Data/Binary/Defer/Class.hs --- a/src/Data/Binary/Defer/Class.hs +++ b/src/Data/Binary/Defer/Class.hs @@ -4,7 +4,8 @@ import Control.Monad import Data.Binary.Defer.Monad import Data.Binary.Raw - +import Data.ByteString(ByteString) +import General.Util(splitAtLength) --------------------------------------------------------------------- -- BinaryDefer @@ -34,6 +35,7 @@ get4 f = do x1 <- get; x2 <- get; x3 <- get; x4 <- get; return (f x1 x2 x3 x4) get5 f = do x1 <- get; x2 <- get; x3 <- get; x4 <- get; x5 <- get; return (f x1 x2 x3 x4 x5) get6 f = do x1 <- get; x2 <- get; x3 <- get; x4 <- get; x5 <- get; x6 <- get; return (f x1 x2 x3 x4 x5 x6) +get7 f = do x1 <- get; x2 <- get; x3 <- get; x4 <- get; x5 <- get; x6 <- get; x7 <- get; return (f x1 x2 x3 x4 x5 x6 x7) getFixed0 f = return f @@ -52,6 +54,7 @@ put4 x1 x2 x3 x4 = put x1 >> put x2 >> put x3 >> put x4 put5 x1 x2 x3 x4 x5 = put x1 >> put x2 >> put x3 >> put x4 >> put x5 put6 x1 x2 x3 x4 x5 x6 = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 +put7 x1 x2 x3 x4 x5 x6 x7 = put x1 >> put x2 >> put x3 >> put x4 >> put x5 >> put x6 >> put x7 putFixed0 = return () :: DeferPut () @@ -63,6 +66,13 @@ putFixed6 x1 x2 x3 x4 x5 x6 = putFixed x1 >> putFixed x2 >> putFixed x3 >> putFixed x4 >> putFixed x5 >> putFixed x6 +putEnumByte :: Enum a => a -> DeferPut () +putEnumByte x = putByte $ fromIntegral $ fromEnum x + +getEnumByte :: Enum a => DeferGet a +getEnumByte = liftM (toEnum . fromIntegral) getByte + + instance BinaryDefer Int where put = putInt get = getInt @@ -155,18 +165,30 @@ -- strategy: write out in 100 byte chunks, where each successive -- chunk is lazy, but the first is not instance BinaryDefer a => BinaryDefer [a] where - put xs | null b = putByte (length a) >> mapM_ put a - | otherwise = putByte maxByte >> mapM_ put a >> putDefer (put b) - where (a,b) = splitAt 100 xs + put xs = putList xs get = do i <- getByte if i /= maxByte then do - replicateM i get + replicateM (fromIntegral i) get else do xs <- replicateM 100 get ys <- getDefer get return (xs++ys) + + +-- Extracted to allow putList to appear on the profile +putList :: BinaryDefer a => [a] -> DeferPut () +putList xs | null b = putByte (fromIntegral n) >> mapM_ put a + | otherwise = putByte maxByte >> mapM_ put a >> putDefer (put b) + where (n,a,b) = splitAtLength 100 xs + + +instance BinaryDefer ByteString where + put = putDefer . putByteString + get = getDefer getByteString + putFixed = put + getFixed = get newtype Defer a = Defer a diff --git a/src/Data/Binary/Defer/Graph.hs b/src/Data/Binary/Defer/Graph.hs deleted file mode 100644 --- a/src/Data/Binary/Defer/Graph.hs +++ /dev/null @@ -1,136 +0,0 @@ - -module Data.Binary.Defer.Graph( - Graph, GraphNode, showGraphWith, - searchDijkstraState, searchDijkstraCycle, - Graph_(..), newGraph_, - graphFreeze, graphFollow - ) where - -import Data.Binary.Defer -import Data.Binary.Defer.Array -import Data.List -import General.Code -import qualified Data.Heap as Heap -import qualified Data.Map as Map -import qualified Data.Set as Set - - ---------------------------------------------------------------------- --- GRAPH - -data Graph n e = Graph (Array (Node n e)) - -data Node n e = Node {nodeResults :: [n], nodeEdges :: [(e, GraphNode)]} - -type GraphNode = Int - - -showGraphWith :: (Show n, Show e) => (GraphNode -> String) -> Graph n e -> String -showGraphWith showNode (Graph xs) = unlines $ concat $ zipWith f [0..] $ elems xs - where - f i (Node res es) = showNode i : map (" "++) (r : map g es) - where r = if null res then "No results" else unwords (map show res) - - g (e,n) = showNode n ++ " ==> " ++ show e - - -instance (Show n, Show e) => Show (Graph n e) where - show = showGraphWith (\x -> '#':show x) - - -instance (BinaryDefer n, BinaryDefer e) => BinaryDefer (Graph n e) where - put (Graph a) = put1 a - get = get1 Graph - -instance (BinaryDefer n, BinaryDefer e) => BinaryDefer (Node n e) where - put (Node a b) = put2 a b - get = get2 Node - - --- Given an initial (cost,state), and how to transform a (cost,state) along an edge --- return the (cost,state,node) pairs with the invariants that: --- Items are returned sorted by c --- No (_,s,n) pair is returned twice -searchDijkstraState :: (Ord c, Ord s) => - (c,s) -> (e -> (c,s) -> (c,s)) -> - GraphNode -> Graph n e -> [(c,s,n)] -searchDijkstraState (c,s) gen n (Graph xs) = f Set.empty (Heap.singleton c (s,n)) - where - f seen next = case Heap.pop next of - Nothing -> [] - Just ((c,(s,n)),next) - | (s,n) `Set.member` seen -> f seen next - | otherwise -> [(c,s,n) | n <- ns] ++ f seen2 next2 - where Node ns es = xs ! n - seen2 = Set.insert (s,n) seen - next2 = Heap.insertList [(c2,(s2,n)) | (e,n) <- es, let (c2,s2) = gen e (c,s)] next - - --- Invariant: No node is reached going through that node -searchDijkstraCycle :: Ord c => - c -> (e -> c -> Maybe c) -> - GraphNode -> Graph n e -> [(c,n)] -searchDijkstraCycle c gen n (Graph xs) = f (Heap.singleton c (Set.singleton n,n)) - where - f next = case Heap.pop next of - Nothing -> [] - Just ((c,(s,n)),next) -> [(c,n) | n <- ns] ++ f (Heap.insertList new next) - where Node ns es = xs ! n - new = [ (c2, (Set.insert n s,n)) - | (e,n) <- es, not $ n `Set.member` s - , Just c2 <- [gen e c]] - - ---------------------------------------------------------------------- --- MUTABLE GRAPH - -data Graph_ k n e = Graph_ {graphResults :: [(k,n)], graphEdges :: [(k,k,e)]} - deriving Show - - -newGraph_ :: Graph_ k n e -newGraph_ = Graph_ [] [] - - -graphKeys :: Graph_ k n e -> [k] -graphKeys (Graph_ res es) = map fst res ++ concatMap (\(a,b,c) -> [a,b]) es - - --- follow a node, if you create a new node, keep following -graphFollow :: Ord k => (k -> [(k,e)]) -> Graph_ k n e -> Graph_ k n e -graphFollow next g = g{graphEdges = graphEdges g ++ f Set.empty (graphKeys g)} - where - f seen [] = [] - f seen (t:odo) - | t `Set.member` seen = f seen odo - | otherwise = - [(t,k,e) | (k,e) <- nxt] ++ f (Set.insert t seen) (map fst nxt ++ odo) - where nxt = next t - - -graphFreeze :: Ord k => Graph_ k n e -> (Graph n e, Map.Map k GraphNode) -graphFreeze (Graph_ res es) = (g, r) - where - g = Graph $ array $ map snd $ sortFst $ Map.elems mp - r = Map.map fst mp - mp = foldl' addEdge (foldl' addNode Map.empty (reverse res)) (reverse es) - - -- mp :: Map (key, (GraphNode, Node n e)) - addNode mp (k1,n) = Map.insertWith f k1 new mp - where - new = (Map.size mp, Node [n] []) - f new (i, Node ns es) = (i, Node (n:ns) es) - - addEdge mp (k1,k2,e) = Map.insertWith f k1 new mp3 - where - -- ensureKey k1 is important, even though ki1 is not needed - -- otherwise k1 may not make it into the map - (mp2,ki1) = ensureKey k1 mp - (mp3,ki2) = ensureKey k2 mp2 - new = (Map.size mp, Node [] [(e, ki2)]) - f new (i, Node ns es) = (i, Node ns ((e,ki2):es)) - - ensureKey k mp = case Map.lookup k mp of - Just (y,_) -> (mp, y) - Nothing -> (Map.insert k (n, Node [] []) mp, n) - where n = Map.size mp diff --git a/src/Data/Binary/Defer/Index.hs b/src/Data/Binary/Defer/Index.hs --- a/src/Data/Binary/Defer/Index.hs +++ b/src/Data/Binary/Defer/Index.hs @@ -3,7 +3,7 @@ Id, Index, newIndex, Lookup, newLookup, lookupKey, lookupIndex, - Link, newLink, fromLink, linkKey, + Link, newLink, fromLink, linkKey, indexLinks, Index_, newIndex_, getLink, getLookup, indexFreeze ) where @@ -107,6 +107,10 @@ size _ = size (0 :: Id) putFixed = put getFixed = get + + +indexLinks :: Index a -> [Link a] +indexLinks (Index x) = zipWith newLink [0..] $ elems x --------------------------------------------------------------------- diff --git a/src/Data/Binary/Defer/Monad.hs b/src/Data/Binary/Defer/Monad.hs --- a/src/Data/Binary/Defer/Monad.hs +++ b/src/Data/Binary/Defer/Monad.hs @@ -1,63 +1,179 @@ -module Data.Binary.Defer.Monad where +module Data.Binary.Defer.Monad( + DeferPut, putDefer, runDeferPut, + putInt, putByte, putChr, putByteString, + DeferGet, getDefer, runDeferGet, + getInt, getByte, getChr, getByteString, + getDeferGet, getDeferPut + ) where import System.IO import System.IO.Unsafe import Data.Binary.Raw import Control.Monad.Reader import Data.IORef +import qualified Data.ByteString as BS import Data.Typeable import qualified Data.TypeMap as TypeMap +import Foreign --------------------------------------------------------------------- -- Defer Put -type DeferPut a = ReaderT (Handle, IORef [DeferPending]) IO a -data DeferPending = DeferPending Integer (DeferPut ()) +-- Storing the position explicitly gives a ~5% speed up +-- and removes hGetPos as being a bottleneck +-- possibly still not worth it though -putInt, putByte :: Int -> DeferPut () -putInt x = do h <- asks fst; lift $ hPutInt h x -putByte x = do h <- asks fst; lift $ hPutByte h x +type DeferPut a = ReaderT (Buffer, IORef [DeferPending], IORef [DeferPatchup]) IO a +data DeferPending = DeferPending !Int (DeferPut ()) +data DeferPatchup = DeferPatchup !Int !Int -- a b = at position a, write out b +putValue :: Storable a => a -> DeferPut () +putValue x = do + (buf,_,_) <- ask + lift $ bufferAdd buf x + +putInt :: Int -> DeferPut () +putInt x = putValue (fromIntegral x :: Int32) + +putByte :: Word8 -> DeferPut () +putByte x = putValue x + putChr :: Char -> DeferPut () -putChr x = do h <- asks fst; lift $ hPutChar h x +putChr x = putByte $ fromIntegral $ fromEnum x +putByteString :: BS.ByteString -> DeferPut () +putByteString x = do + (buf,_,_) <- ask + putInt $ BS.length x + lift $ bufferAddByteString buf x + putDefer :: DeferPut () -> DeferPut () putDefer x = do - (h,ref) <- ask - p <- lift $ hGetPos h - lift $ hPutInt h 0 -- to backpatch - lift $ modifyIORef ref (DeferPending p x :) + (buf,ref,_) <- ask + lift $ do + p <- bufferPos buf + bufferAdd buf (0 :: Int32) -- to backpatch + modifyIORef ref (DeferPending p x :) runDeferPut :: Handle -> DeferPut () -> IO () runDeferPut h m = do + buf <- bufferNew h ref <- newIORef [] - runReaderT m (h,ref) - todo <- readIORef ref - mapM_ (runDeferPending h) (reverse todo) + back <- newIORef [] + runReaderT (m >> runDeferPendings) (buf,ref,back) + bufferFlush buf + patch <- readIORef back + mapM_ (\(DeferPatchup a b) -> do hSetPos h (toInteger a); hPutInt h b) patch -runDeferPending :: Handle -> DeferPending -> IO () -runDeferPending h (DeferPending pos act) = do + +runDeferPendings :: DeferPut () +runDeferPendings = do + (_,ref,back) <- ask + todo <- lift $ readIORef ref + lift $ writeIORef ref [] + mapM_ runDeferPending todo + + +runDeferPending :: DeferPending -> DeferPut () +runDeferPending (DeferPending pos act) = do + (buf,_,back) <- ask + lift $ do + p <- bufferPos buf + b <- bufferPatch buf pos (fromIntegral p :: Int32) + when (not b) $ modifyIORef back (DeferPatchup pos p :) + act + runDeferPendings + + +--------------------------------------------------------------------- +-- Buffer for writing + +bufferSize = 10000 :: Int + +-- (number in file, number in buffer) +data Buffer = Buffer !Handle !(IORef Int) !(Ptr ()) !(IORef Int) + + +bufferNew :: Handle -> IO Buffer +bufferNew h = do i <- hGetPos h - hSetPos h pos - hPutInt h (fromInteger i) - hSetPos h i - runDeferPut h act + file <- newIORef $ fromInteger i + buf <- newIORef 0 + ptr <- mallocBytes bufferSize + return $ Buffer h file ptr buf +bufferAdd :: Storable a => Buffer -> a -> IO () +bufferAdd (Buffer h file ptr buf) x = do + let sz = sizeOf x + buf2 <- readIORef buf + if sz + buf2 >= bufferSize then do + hPutBuf h ptr buf2 + pokeByteOff ptr 0 x + modifyIORef file (+buf2) + writeIORef buf sz + else do + pokeByteOff ptr buf2 x + writeIORef buf (buf2+sz) + + +bufferAddByteString :: Buffer -> BS.ByteString -> IO () +bufferAddByteString (Buffer h file ptr buf) x = do + let sz = BS.length x + buf2 <- readIORef buf + when (buf2 /= 0) $ do + hPutBuf h ptr buf2 + writeIORef buf 0 + modifyIORef file (+ (buf2+sz)) + BS.hPut h x + + +bufferFlush :: Buffer -> IO () +bufferFlush (Buffer h file ptr buf) = do + buf2 <- readIORef buf + hPutBuf h ptr buf2 + modifyIORef file (+buf2) + writeIORef buf 0 + + +bufferPos :: Buffer -> IO Int +bufferPos (Buffer h file ptr buf) = do + i <- readIORef file + j <- readIORef buf + return $ i + j + + +-- Patch at position p, with value v +-- Return True if you succeeded +bufferPatch :: Buffer -> Int -> Int32 -> IO Bool +bufferPatch (Buffer h file ptr buf) p v = do + i <- readIORef file + if p < i then return False else do + pokeByteOff ptr (p-i) v + return True + --------------------------------------------------------------------- -- Defer Get type DeferGet a = ReaderT (Handle, IORef TypeMap.TypeMap) IO a -getInt, getByte :: DeferGet Int +getInt :: DeferGet Int getInt = do h <- asks fst; lift $ hGetInt h -getByte = do h <- asks fst; lift $ hGetByte h +getByte :: DeferGet Word8 +getByte = do h <- asks fst; lift $ liftM fromIntegral $ hGetByte h + getChr :: DeferGet Char getChr = do h <- asks fst; lift $ hGetChar h + +getByteString :: DeferGet BS.ByteString +getByteString = do + h <- asks fst + len <- lift $ hGetInt h + lift $ BS.hGet h len getDefer :: DeferGet a -> DeferGet a getDefer x = do diff --git a/src/Data/Binary/Defer/Trie.hs b/src/Data/Binary/Defer/Trie.hs --- a/src/Data/Binary/Defer/Trie.hs +++ b/src/Data/Binary/Defer/Trie.hs @@ -1,6 +1,6 @@ module Data.Binary.Defer.Trie( - Trie, newTrie, lookupTrie + Trie, newTrie, lookupTrie, unionsWith ) where import Data.Binary.Defer @@ -10,6 +10,7 @@ -- Keep simple first, can move to an Array later if necessary +-- the second list is always ordered data Trie a = Trie (Maybe a) [(Char,Trie a)] deriving Eq @@ -30,6 +31,29 @@ lookupTrie :: String -> Trie a -> Maybe a lookupTrie [] (Trie a b) = a lookupTrie (x:xs) (Trie a b) = lookup x b >>= lookupTrie xs + + +unionsWith :: (a -> a -> a) -> [Trie a] -> Trie a +unionsWith f [] = newTrie [] +unionsWith f [x] = x +unionsWith f (x:xs) = foldl (unionWith f) x xs + + +unionWith :: (a -> a -> a) -> Trie a -> Trie a -> Trie a +unionWith merge (Trie x xs) (Trie y ys) = Trie xy $ f xs ys + where + xy = case (x,y) of + (Just x, Nothing) -> Just x + (Nothing, Just y) -> Just y + (Just x, Just y) -> Just $ merge x y + (Nothing,Nothing) -> Nothing + + f ((x1,x2):xs) ((y1,y2):ys) = case compare x1 y1 of + EQ -> (x1,unionWith merge x2 y2) : f xs ys + LT -> (x1,x2) : f xs ((y1,y2):ys) + GT -> (y1,y2) : f ((x1,x2):xs) ys + f xs [] = xs + f [] ys = ys instance BinaryDefer a => BinaryDefer (Trie a) where diff --git a/src/Data/Binary/Raw.hs b/src/Data/Binary/Raw.hs --- a/src/Data/Binary/Raw.hs +++ b/src/Data/Binary/Raw.hs @@ -12,6 +12,7 @@ import System.IO import Control.Monad import Data.Bits +import Data.Word import Data.Char @@ -22,7 +23,7 @@ hSetPos hndl i = hSeek hndl AbsoluteSeek i -maxByte :: Int +maxByte :: Word8 maxByte = 0xff -- FROM the Binary module, thanks to the Hac 07 people! diff --git a/src/General/Code.hs b/src/General/Code.hs --- a/src/General/Code.hs +++ b/src/General/Code.hs @@ -22,5 +22,5 @@ import System.Directory import System.Environment import System.Exit -import System.FilePath hiding (FilePath) +import System.FilePath hiding (FilePath,combine) import System.IO diff --git a/src/General/Util.hs b/src/General/Util.hs --- a/src/General/Util.hs +++ b/src/General/Util.hs @@ -252,3 +252,18 @@ errorLines :: [String] -> b errorLines [] = error "errorLines, finished" errorLines (x:xs) = trace x $ errorLines xs + + +rep from to x = if x == from then to else x + + +-- | Like splitAt, but also return the number of items that were split. +-- For performance. +splitAtLength :: Int -> [a] -> (Int,[a],[a]) +splitAtLength n xs = f n xs + where + f i xs | i == 0 = (n,[],xs) + f i [] = (n-i,[],[]) + f i (x:xs) = (a,x:b,c) + where (a,b,c) = f (i-1) xs + diff --git a/src/Hoogle/All.hs b/src/Hoogle/All.hs --- a/src/Hoogle/All.hs +++ b/src/Hoogle/All.hs @@ -3,8 +3,9 @@ Query(..), parseQuery, renderQuery, suggestQuery, usefulQuery, Flag(..), DataBase, loadDataBase, showDataBase, - convert, rank, - searchAll, searchRange, Result(..) + convert, rank, combine, + searchAll, searchRange, Result(..), + completions ) where import Hoogle.Query.All diff --git a/src/Hoogle/DataBase/Aliases.hs b/src/Hoogle/DataBase/Aliases.hs --- a/src/Hoogle/DataBase/Aliases.hs +++ b/src/Hoogle/DataBase/Aliases.hs @@ -1,6 +1,6 @@ module Hoogle.DataBase.Aliases( - Aliases, createAliases, normAliases + Aliases, createAliases, normAliases, mergeAliases ) where import Hoogle.TextBase.All @@ -11,10 +11,10 @@ import General.Code -newtype Aliases = Aliases (Map.Map String Alias) +newtype Aliases = Aliases {fromAliases :: Map.Map String Alias} instance BinaryDefer Aliases where - put (Aliases a) = put a + put = put . fromAliases get = get1 Aliases instance Show Aliases where @@ -32,11 +32,19 @@ get = get2 Alias -createAliases :: [TextItem] -> Aliases -createAliases ti = Aliases $ transitiveClosure $ Map.fromList - [ (name, Alias [v | TVar v <- args] rhs) - | ItemAlias (TypeSig _ lhs) (TypeSig _ rhs) <- ti - , let (TLit name, args) = fromTApp lhs] +createAliases :: [Aliases] -> [TextItem] -> Aliases +createAliases deps ti = mergeAliases (a:deps) + where + a = Aliases $ transitiveClosure $ Map.fromList + [ (name, Alias [v | TVar v <- args] rhs) + | ItemAlias (TypeSig _ lhs) (TypeSig _ rhs) <- ti + , let (TLit name, args) = fromTApp lhs] + + +-- the first is the most important +mergeAliases :: [Aliases] -> Aliases +mergeAliases [x] = x +mergeAliases xs = Aliases $ transitiveClosure $ Map.unions $ map fromAliases xs -- Must be careful with aliases which expand back to themselves diff --git a/src/Hoogle/DataBase/All.hs b/src/Hoogle/DataBase/All.hs --- a/src/Hoogle/DataBase/All.hs +++ b/src/Hoogle/DataBase/All.hs @@ -12,19 +12,33 @@ import Hoogle.DataBase.Type import Hoogle.Item.All import Hoogle.DataBase.Serialise +import General.Code -createDataBase :: TextBase -> DataBase -createDataBase xs = DataBase items - (createNameSearch ys) (createTypeSearch aliases instances ys) - (createSuggest ys) aliases instances +createDataBase :: [DataBase] -> TextBase -> DataBase +createDataBase deps xs = DataBase items + (createNameSearch ys) (createTypeSearch as is ys) + (createSuggest (map suggest deps) zs) as is where - (items,ys) = createItems xs - zs = map fst ys - aliases = createAliases zs - instances = createInstances zs + items = createItems xs + ys = entriesItems items + zs = map fst xs + as = createAliases (map aliases deps) zs + is = createInstances (map instances deps) zs +combineDataBase :: [DataBase] -> DataBase +combineDataBase dbs = DataBase items_ + (createNameSearch ys) (createTypeSearch as is ys) + ss as is + where + items_ = mergeItems $ map items dbs + ys = entriesItems items_ + ss = mergeSuggest $ map suggest dbs + as = mergeAliases $ map aliases dbs + is = mergeInstances $ map instances dbs + + searchName :: DataBase -> String -> [(Link Entry,EntryView,TextScore)] searchName db = searchNameSearch (nameSearch db) @@ -36,3 +50,7 @@ suggestion :: [DataBase] -> TypeSig -> Maybe (Either String TypeSig) suggestion db = askSuggest (map suggest db) + + +completions :: DataBase -> String -> [String] +completions db = completionsNameSearch (nameSearch db) diff --git a/src/Hoogle/DataBase/Instances.hs b/src/Hoogle/DataBase/Instances.hs --- a/src/Hoogle/DataBase/Instances.hs +++ b/src/Hoogle/DataBase/Instances.hs @@ -1,6 +1,6 @@ module Hoogle.DataBase.Instances( - Instances, createInstances, + Instances, createInstances, mergeInstances, normInstances, hasInstance ) where @@ -13,7 +13,7 @@ -- Map type [classes] -newtype Instances = Instances (Map.Map String [String]) +newtype Instances = Instances {fromInstances :: Map.Map String [String]} instance Show Instances where show (Instances mp) = unlines $ map f $ Map.toList mp @@ -21,15 +21,22 @@ instance BinaryDefer Instances where - put (Instances x) = put1 x + put = put1 . fromInstances get = get1 Instances -createInstances :: [TextItem] -> Instances -createInstances xs = Instances $ foldl f Map.empty ys +createInstances :: [Instances] -> [TextItem] -> Instances +createInstances deps xs = mergeInstances (i:deps) where + i = Instances $ foldl f Map.empty ys ys = [(v, c) | ItemInstance (TypeSig [] (TApp (TLit c) vs)) <- xs, TLit v <- vs] f mp (v,c) = Map.insertWith (++) v [c] mp + + +mergeInstances :: [Instances] -> Instances +mergeInstances = Instances . Map.unionsWith (\x y -> nub $ x ++ y) . map fromInstances + + -- Convert: diff --git a/src/Hoogle/DataBase/Items.hs b/src/Hoogle/DataBase/Items.hs --- a/src/Hoogle/DataBase/Items.hs +++ b/src/Hoogle/DataBase/Items.hs @@ -34,58 +34,75 @@ -- temporary state structure -data S = S {pkg :: Package - ,modId :: Int - ,mods :: [Module] - ,modCur :: Maybe (Link Module) - ,entId :: Int - ,ents :: [(TextItem, Maybe Entry)] - } +data S a = S {count :: Int, values :: [a]} -createItems :: [(TextItem,String)] -> (Items, [(TextItem, Maybe (Link Entry))]) -createItems xs = res - where - res = unS $ execState (mapM (uncurry f) xs) s0 - s0 = S (Package "" "" "" "") 0 [] Nothing 0 [] +newS = S (-1) [] +newIndexS = newIndex . reverse . values +addS x (S i xs) = S (i+1) (x:xs) +getS (S i (x:xs)) = newLink i x +getS _ = error "DataBase.Items.getS, lacking a package/module?" - unS s = (Items (newIndex [pkg s]) - ms - (newIndex $ mapMaybe (liftM fromLink . snd) esJ2) - ,map (id *** const Nothing) esN ++ esJ2) - where - ms = newIndex $ reverse $ mods s - (esJ,esN) = partition (isJust . snd) $ ents s - esJ2 = zipWith (\i (ti,Just e) -> (ti,Just $ newLink i e)) [0..] $ - sortOn (entryScore . fromJust . snd) esJ - f :: TextItem -> String -> State S () - f i@ItemInstance{} _ = addTextItem i +entriesItems :: Items -> [Link Entry] +entriesItems = indexLinks . entries - f i@(ItemAttribute "keyword" name) d = addEntry i False EntryKeyword d - [Keyword "keyword",Text " ",Focus name] - f i@(ItemAttribute name val) _ = do - addTextItem i - when (name == "package") $ modify $ \s -> s{pkg = (pkg s){packageName = val}} - when (name == "version") $ modify $ \s -> s{pkg = (pkg s){packageVersion = val}} +createItems :: [(TextItem,String)] -> Items +createItems xs = Items (newIndexS pkgs) (newIndexS mods) + (newIndex $ sortOn entryScore ents) + where + (ents, (pkgs,mods)) = flip runState (newS,newS) $ concatMapM addTextItem $ init $ tails xs - f i@(ItemModule xs) d = do - s <- get - let modI = modId s - m = Module xs (newLink 0 $ lookupIndex (newLookup 0) (packages $ fst res)) - put s{modId = modI + 1, mods = m : mods s - ,modCur = Just $ newLink modI m} - addEntry i True EntryModule d - [Keyword "module", Text $ ' ' : concatMap (++ ".") (init xs), Focus (last xs)] - f i d = addEntry i True EntryOther d (renderTextItem i) +-- add a TextItem to the state S +addTextItem :: [(TextItem,String)] -> State (S Package, S Module) [Entry] +addTextItem ((ti,doc):rest) = case ti of + ItemInstance{} -> return [] - addTextItem i = modify $ \s -> s{ents = (i,Nothing) : ents s} + ItemAttribute "keyword" name -> + add False EntryKeyword [Keyword "keyword",Text " ",Focus name] - addEntry i modu typ doc txt = do - s <- get - let entI = entId s - e = Entry (if modu then modCur s else Nothing) + ItemAttribute "package" name -> do + modify $ \(ps,ms) -> (addS (addPkg (Package name "" "" "") rest) ps, ms) + add False EntryPackage [Keyword "package",Text " ",Focus name] + + ItemAttribute _ _ -> return [] + + ItemModule xs -> do + modify $ \(ps,ms) -> (ps, addS (Module xs) ms) + add True EntryModule [Keyword "module", Text $ ' ' : concatMap (++ ".") (init xs), Focus (last xs)] + + _ -> add True EntryOther (renderTextItem ti) + where + add modu typ txt = do + (ps,ms) <- get + let sig = case ti of ItemFunc _ s -> Just (Defer s); _ -> Nothing + return [Entry (if modu then Just $ getS ms else Nothing) (getS ps) (headDef "" [i | Focus i <- txt]) - txt typ (newHaddock doc) - put $ s{entId = entI + 1, ents = (i, Just e) : ents s} + txt typ (newHaddock doc) sig] + + addPkg pkg ((ItemAttribute "version" x,_) : xs) = addPkg pkg{packageVersion=x} xs + addPkg pkg ((ItemAttribute "haddock" x,_) : xs) = addPkg pkg{haddockURL =x} xs + addPkg pkg ((ItemAttribute "hackage" x,_) : xs) = addPkg pkg{hackageURL =x} xs + addPkg pkg _ = pkg + + +mergeItems :: [Items] -> Items +mergeItems [x] = x +mergeItems xs = Items + (newIndex $ concat $ reverse ps) + (newIndex $ concat $ reverse ms) + (newIndex $ sortOn entryScore $ concat $ reverse es) + where + (pi,ps,mi,ms,ei,es) = foldl' f (0,[],0,[],0,[]) xs + + f (pi,ps,mi,ms,ei,es) (Items p m e) = + (pi+length p3,p3:ps, mi+length m3,m3:ms, ei+length e3,e3:es) + where + (p2,p3) = add pi p id + (m2,m3) = add mi m id + (e2,e3) = add ei e $ \x -> x{entryModule = liftM (\x -> m2 !! linkKey x) $ entryModule x + ,entryPackage = p2 !! linkKey (entryPackage x)} + + add i xs f = (zipWith newLink [i..] xs2, xs2) + where xs2 = map (f . fromLink) $ indexLinks xs diff --git a/src/Hoogle/DataBase/NameSearch.hs b/src/Hoogle/DataBase/NameSearch.hs --- a/src/Hoogle/DataBase/NameSearch.hs +++ b/src/Hoogle/DataBase/NameSearch.hs @@ -2,14 +2,13 @@ module Hoogle.DataBase.NameSearch (NameSearch, createNameSearch ,TextScore, searchNameSearch + ,completionsNameSearch ) where import Data.Binary.Defer -import Data.Binary.Defer.Trie -import Data.Binary.Defer.Chunk +import Data.Binary.Defer.Array import Data.Binary.Defer.Index -import Data.Char -import Data.List +import qualified Data.Map as Map import Data.Range import General.Code import Hoogle.Item.All @@ -19,85 +18,77 @@ --------------------------------------------------------------------- -- DATA TYPES -data NameSearch = NameSearch (Trie NameItem) (Chunk (Int,Link Entry)) - deriving Show +{- +The idea is that NameItem's are sorted by name, so exact/start matching +is done by binary searching this list. -data NameItem = NameItem {nameStart :: Int - ,nameCountAll :: Int -- number that match exactly - ,nameCountAny :: Int -- number that match a prefix - } +The rest of the results are taken by unioning all the suggestions in the +second element, and searching in order. All the results will end up +sorted by name (since they have identical names) -instance Show NameItem where - show (NameItem a b c) = unwords $ map show [a,b,c] +The original code was based around a Trie, gave fast performance, but +didn't merge common strings and consumed about 10x the disk space. +-} -instance BinaryDefer NameSearch where - put (NameSearch a b) = put2 a b - get = get2 NameSearch +data NameSearch = NameSearch (Array NameItem) [(Char, IntList)] -instance BinaryDefer NameItem where - put (NameItem a b c) = put3 a b c - get = get3 NameItem +data NameItem = NameItem {key :: String + ,rest :: Defer [(String, [Link Entry])]} -{- -TRIE data structure -Given the functions "map" and "pm" we would generate: +instance Show NameSearch where + show (NameSearch a b) = + concat (zipWith (\a b -> show a ++ " " ++ show b) [0..] (elems a)) ++ + unlines [c : " = " ++ show d | (c,d) <- b] -Trie: -"ap" (0,1,1) -"m" (1,1,2) -"ma" (2,0,1) -"map" (2,1,1) -"p" (3,1,2) -"pm" (4,1,1) +instance Show NameItem where + show (NameItem a b) = unlines $ a : map f (fromDefer b) + where f (a,b) = unwords $ " " : a : ['#' : show (linkKey x) | x <- b] -Chunk: -0 "ap" (1,[map]) -1 "m" (1,[pm]) -2 "map" (0,[map]) -3 "p" (2,[map]) -4 "pm" (0,[pm]) +instance BinaryDefer NameSearch where + put (NameSearch a b) = put2 a b + get = get2 NameSearch -There will be one trie entry per unique substring. -There will be one chunk entry per suffix. -Both are sorted by the string they represent. +instance BinaryDefer NameItem where + put (NameItem a b) = put2 a b + get = get2 NameItem -[item] is the id of the item. --} --------------------------------------------------------------------- -- CREATION -createNameSearch :: [(a, Maybe (Link Entry))] -> NameSearch -createNameSearch xs = NameSearch - (newTrie $ f sub (zip [0..] pre)) - (newChunk $ map snd pre) +createNameSearch :: [Link Entry] -> NameSearch +createNameSearch xs = NameSearch (array $ Map.elems items) (Map.toList shortcuts) where - ys = extractText xs - sub = map head $ group $ sort $ concatMap (substrs . fst) ys - pre = sortBy (compare `on` fst) - [(p,(i,e)) | (s,e) <- ys, (i,p) <- zip [0..] $ prefixes s] + items = buildItems xs + shortcuts = buildShortcuts items - f :: [String] -> [(Int,(String,a))] -> [(String,NameItem)] - f [] _ = [] - f (x:xs) ys = (x,NameItem s neq (neq+npr)) : f xs ys2 - where - s = fst $ head ys - (neq,npr) = (length eq, length pr) - (eq,ys2) = span ((==) x . fst . snd) ys - pr = takeWhile (isPrefixOf x . fst . snd) ys2 +buildShortcuts :: Map.Map String NameItem -> Map.Map Char IntList +buildShortcuts = Map.map (toIntList . sort) . foldl' add Map.empty . zip [0..] . Map.keys + where + add mp (i,s) = foldl' g mp $ nub s + where g mp x = Map.insertWith (++) x [i] mp -extractText :: [(a, Maybe (Link Entry))] -> [(String, Link Entry)] -extractText xs = [(map toLower s, e) |(_, Just e) <- xs, Focus s <- entryText $ fromLink e] +buildItems :: [Link Entry] -> Map.Map String NameItem +buildItems = Map.map norm . foldl' add Map.empty + where + add mp e = Map.insertWith f ltext (NameItem ltext $ Defer [(text, [e])]) mp + where + text = entryName $ fromLink e + ltext = map toLower text -substrs, prefixes :: [a] -> [[a]] -substrs = concatMap (tail . inits) . prefixes -prefixes = init . tails + f _ (NameItem a b) = NameItem a $ Defer $ g $ fromDefer b + g [] = [(text, [e])] + g ((x1,x2):xs) | x1 == text = (x1, e : x2) : xs + | otherwise = (x1,x2) : g xs + norm (NameItem a b) = NameItem a $ Defer $ f $ fromDefer b + where f x = sortFst [(a, sortOn linkKey b) | (a,b) <- x] + --------------------------------------------------------------------- -- SEARCHING @@ -111,25 +102,128 @@ show TSNone = "_" +{- +Step 1: Binary search for find the exact match +Step 2: Follow from that item finding ones which start +Step 3: Use the hint set to merge into a list of results +-} + searchNameSearch :: NameSearch -> String -> [(Link Entry,EntryView,TextScore)] -searchNameSearch (NameSearch trie chunk) str = - case lookupTrie (map toLower str) trie of - Nothing -> [] - Just i -> nubIntOn (linkKey . fst3) $ order exact0E ++ order (exact0S ++ start) ++ order none +searchNameSearch (NameSearch items shortcuts) str = step1 ++ step2 ++ step3 + where + lstr = map toLower str + nstr = length str + rangePrefix = FocusOn $ rangeStartCount 0 nstr + + (exact,prefix) = startPos items lstr + (prefixes,lastpre) = followPrefixes items lstr prefix + + + step1 = if isJust exact then f TSExact yes ++ f TSStart no else [] where - (exact0,exactN) = partition ((==) 0 . fst) exact - (partial0,partialN) = partition ((==) 0 . fst) partial - (exact,partial) = splitAt (nameCountAll i) $ - lookupChunk (rangeStartCount (nameStart i) (nameCountAny i)) chunk + (yes,no) = partition ((==) str . fst) $ fromDefer $ rest $ items ! fromJust exact + f scr xs = [(x, rangePrefix, scr) | x <- concatMap snd xs] - none = map (f $ const TSNone) $ exactN ++ partialN - (exact0E,exact0S) = partition ((==) TSExact . thd3) $ map (f test) exact0 - start = map (f $ const TSStart) partial0 - test e = if entryName e == str then TSExact else TSStart + step2 = [(x, rangePrefix, TSStart) | x <- prefixes] + + seen i = fromMaybe prefix exact <= i && i <= lastpre + step3 = [(e,view,TSNone) | i <- xs, let x = items ! i + , Just p <- [testMatch lstr $ key x] + , let view = FocusOn $ rangeStartCount p nstr + , e <- concatMap snd $ fromDefer $ rest x] + where xs = filter (not . seen) $ intersectOrds $ + map (maybe [] fromIntList . flip lookup shortcuts) $ nub lstr + + +-- Return the index of the string as the first component +-- Return the first possible index of the prefix as the second +startPos :: Array NameItem -> String -> (Maybe Int, Int) +startPos xs x = f 0 (arraySize xs - 1) where + f low high | high - low < 3 = g low high + | otherwise = + case compare x (key $ xs ! mid) of + EQ -> (Just mid, mid+1) + GT -> f (mid+1) high + LT -> f low (mid-1) + where + mid = (high + low) `div` 2 + + g low high | low > high = (Nothing, low) + g low high = if k == x then (Just low, low+1) + else if x `isPrefixOf` k then (Nothing, low) + else g (low+1) high + where k = key $ xs ! low + + +-- Return all the items you can match following the prefix +-- Plus the last item that was a valid prefix index +followPrefixes :: Array NameItem -> String -> Int -> ([Link Entry], Int) +followPrefixes xs x i = f i + where + n = arraySize xs + f i | i < n && x `isPrefixOf` key xsi = (concatMap snd (fromDefer $ rest xsi) ++ res, end) + | otherwise = ([],i-1) + where xsi = xs ! i + (res,end) = f (i+1) + + +testMatch :: String -> String -> Maybe Int +testMatch find within = listToMaybe [i | (i,x) <- zip [0..] $ tails within, find `isPrefixOf` x] + + +intersectOrd :: [Int] -> [Int] -> [Int] +intersectOrd (x:xs) (y:ys) = case compare x y of + EQ -> x : intersectOrd xs ys + LT -> intersectOrd xs (y:ys) + GT -> intersectOrd (x:xs) ys +intersectOrd _ _ = [] + + +intersectOrds :: [[Int]] -> [Int] +intersectOrds = fold1 intersectOrd + + +--------------------------------------------------------------------- +-- COMPLETIONS + +completionsNameSearch :: NameSearch -> String -> [String] +completionsNameSearch (NameSearch items _) str = + concatMap (map fst . fromDefer . rest) $ + takeWhile ((lstr `isPrefixOf`) . key) $ + map ((!) items) [start .. arraySize items - 1] + where + lstr = map toLower str nstr = length str - order = sortOn (linkKey . fst3) - f :: (Entry -> TextScore) -> (Int, Link Entry) -> (Link Entry,EntryView,TextScore) - f score (p,e) = (e, FocusOn (rangeStartCount p nstr), score $ fromLink e) + (exact,prefix) = startPos items lstr + start = fromMaybe prefix exact + + +--------------------------------------------------------------------- +-- IntList TYPE + +type IntList = [IntRange] +data IntRange = IntRange !Int !Int + +instance Show IntRange where + show (IntRange a b) = show a ++ ".." ++ show b + +instance BinaryDefer IntRange where + put (IntRange a b) = put2 a b + get = get2 IntRange + + +toIntList :: [Int] -> IntList +toIntList [] = [] +toIntList (x:xs) = f x xs + where + f i [] = [IntRange x i] + f i (y:ys) | y == i+1 = f y ys + | otherwise = IntRange x i : toIntList (y:ys) + + +fromIntList :: IntList -> [Int] +fromIntList = concatMap (\(IntRange a b) -> [a..b]) + diff --git a/src/Hoogle/DataBase/Serialise.hs b/src/Hoogle/DataBase/Serialise.hs --- a/src/Hoogle/DataBase/Serialise.hs +++ b/src/Hoogle/DataBase/Serialise.hs @@ -8,9 +8,13 @@ import General.Code import Hoogle.DataBase.Type +import Paths_hoogle +import Data.Version -hooVersion = 1 :: Int +hooVersion :: [Int] +hooVersion = take 4 $ versionBranch version ++ repeat 0 + hooString = "HOOG" @@ -18,7 +22,7 @@ saveDataBase file db = do h <- openBinaryFile file WriteMode mapM_ (hPutChar h) hooString - hPutInt h hooVersion + mapM_ (hPutByte h) hooVersion runDeferPut h $ put db hClose h @@ -35,9 +39,10 @@ when (str /= hooString) $ error $ "Not a hoogle database: " ++ file - ver <- hGetInt h - when (ver /= hooVersion) $ - error $ "Wrong hoogle database version: " ++ show ver ++ - " found, expected " ++ show hooVersion + let showVer = showVersion . flip Version [] + ver <- replicateM 4 (hGetByte h) + when (ver /= hooVersion && "hugs" `notElem` versionTags version) $ + error $ "Wrong hoogle database version: " ++ showVer ver ++ + " found, expected " ++ showVer hooVersion runDeferGet h get diff --git a/src/Hoogle/DataBase/Suggest.hs b/src/Hoogle/DataBase/Suggest.hs --- a/src/Hoogle/DataBase/Suggest.hs +++ b/src/Hoogle/DataBase/Suggest.hs @@ -1,11 +1,9 @@ --- TODO: Suggestions from imported packages should be detailed - module Hoogle.DataBase.Suggest where import General.Code import Data.Binary.Defer -import Data.Binary.Defer.Trie +import Data.Binary.Defer.Trie as Trie import Data.Binary.Defer.Index import qualified Data.Map as Map import Hoogle.TextBase.All @@ -14,6 +12,8 @@ import Data.Generics.Uniplate +-- TODO: Move to a Map, first benchmark how much this slows down the +-- searching, versus how much space is saved newtype Suggest = Suggest {fromSuggest :: Trie SuggestItem} -- if something is both a data and a ctor, no need to mention the ctor @@ -45,10 +45,11 @@ -- note: do not look inside class's for data type information -- as they may have higher-kinds and get it wrong -createSuggest :: [(TextItem, a)] -> Suggest -createSuggest xs = Suggest $ newTrie $ Map.toList res +createSuggest :: [Suggest] -> [TextItem] -> Suggest +createSuggest deps xs = mergeSuggest (s:deps) where - res = foldl f Map.empty $ concatMap (getTextItem . fst) xs + s = Suggest $ newTrie $ Map.toList res + res = foldl f Map.empty $ concatMap getTextItem xs where f m (s,i) = Map.insertWith joinItem (map toLower s) i m sData c n = (c, SuggestItem Nothing [(c,n)] []) @@ -77,16 +78,22 @@ , (TLit c,_) <- [fromTApp $ last $ fromTFun x]] +mergeSuggest :: [Suggest] -> Suggest +mergeSuggest = Suggest . Trie.unionsWith joinItem . map fromSuggest + + joinItem :: SuggestItem -> SuggestItem -> SuggestItem joinItem (SuggestItem a1 b1 c1) (SuggestItem a2 b2 c2) = SuggestItem (if null b1 && null b2 then a1 `mplus` a2 else Nothing) - (nub $ b1++b2) (nub $ c1++c2) + (f b1 b2) (f c1 c2) + where + f x y = map (id *** maximum) $ sortGroupFsts $ x ++ y askSuggest :: [Suggest] -> TypeSig -> Maybe (Either String TypeSig) askSuggest sug q@(TypeSig con typ) - | typ2 /= typ = Just (Right $ TypeSig con typ2) + | q2 /= q = Just (Right q2) | not $ null datas = unknown "type" datas | not $ null classes = unknown "class" classes | otherwise = Nothing @@ -96,6 +103,12 @@ [] -> Nothing xs -> Just $ foldr1 joinItem xs + con2 = map (improve get True) con + typ2 = improve get False typ + q2 = contextTrim $ insertVars $ TypeSig con2 typ2 + insertVars = transformSig (\x -> if x == TVar "" then TVar var else x) + var = head $ filter (/= "") $ variables typ2 ++ concatMap variables con2 ++ ["a"] + -- figure out if you have a totally unknown thing -- classes = [x | c <- con, (TLit x,_) <- [fromTApp c], bad True x] datas = [x | TLit x <- concatMap universe $ typ : concatMap (snd . fromTApp) con @@ -107,27 +120,45 @@ Just i | cls -> null $ suggestClass i | otherwise -> null (suggestData i) && isNothing (suggestCtor i) - -- try and improve the type -- - typ2 = removeTApp $ transform f $ insertTApp typ - where - free = map (TVar . (:[])) $ ['a'..] \\ [x | TVar [x] <- universe typ] - f (TVar x) | length x > 1 = g (TVar x) x - f (TLit x) = g (TLit x) x - f (TApp (TLit x) xs) | isJust m && not (null kinds) && n `notElem` kinds = - TApp (TLit x) $ if maximum kinds > n - then xs ++ take (minimum (filter (> n) kinds) - n) free - else take (maximum kinds) xs - where - m@ ~(Just SuggestItem{suggestData=d}) = get x - kinds = [b | (a,b) <- d, a == x] - n = length xs - f x = x +-- remove context which doesn't reference variables in the RHS +contextTrim :: TypeSig -> TypeSig +contextTrim (TypeSig con typ) = TypeSig (filter (not . bad) con) typ + where var = variables typ + bad x = isTVar (fst $ fromTApp x) || null (variables x `intersect` var) - g def x | isJust m && x `notElem` (map fst d) && - (not (null d) || isJust c) - = if isJust c then TLit $ fromJust c - else TLit $ fst $ head $ d - where m@ ~(Just SuggestItem{suggestData=d, suggestCtor=c}) = get x - g def x = def +improve :: (String -> Maybe SuggestItem) -> Bool -> Type -> Type +improve get cls typ + | cls == False = f $ transform (improveName nameTyp) typ + | cls == True = improveArity arity $ + tApp (improveName nameCls t1) (map (transform (improveName nameTyp)) ts) + where + (t1,ts) = fromTApp typ + nameTyp = maybe [] (\x -> maybeToList (suggestCtor x) ++ map fst (suggestData x)) . get + nameCls = maybe [] (map fst . suggestClass) . get + + arity x = lookup x . (if cls then suggestClass else suggestData) =<< get x + + f x = case improveArity arity x of + TApp x xs -> TApp x (map f xs) + x -> descend f x + + +-- Given a name, return its arity +improveArity :: (String -> Maybe Int) -> Type -> Type +improveArity f o = case fromTApp o of + (TLit x, xs) -> + case f x of + Just i -> tApp (TLit x) $ take i $ xs ++ repeat (TVar "") + _ -> o + _ -> o + + +-- Given a name, return the names it could possibly be +improveName :: (String -> [String]) -> Type -> Type +improveName f (TLit x) | ys /= [] && x `notElem` ys = TLit (head ys) + where ys = f x +improveName f (TVar x) | length x > 1 && ys /= [] = TLit (head ys) + where ys = f x +improveName f x = x diff --git a/src/Hoogle/DataBase/Type.hs b/src/Hoogle/DataBase/Type.hs --- a/src/Hoogle/DataBase/Type.hs +++ b/src/Hoogle/DataBase/Type.hs @@ -19,14 +19,13 @@ import General.Code +-- suggest, aliases and instances are used for linking with packages +-- that depend on this database data DataBase = DataBase {items :: Items ,nameSearch :: NameSearch ,typeSearch :: TypeSearch ,suggest :: Suggest - -- aliases and instances are stored - -- but only used for linking with packages that depend - -- on this database ,aliases :: Aliases ,instances :: Instances } diff --git a/src/Hoogle/DataBase/TypeSearch/All.hs b/src/Hoogle/DataBase/TypeSearch/All.hs --- a/src/Hoogle/DataBase/TypeSearch/All.hs +++ b/src/Hoogle/DataBase/TypeSearch/All.hs @@ -31,9 +31,9 @@ --------------------------------------------------------------------- -- CREATION -createTypeSearch :: Aliases -> Instances -> [(TextItem, Maybe (Link Entry))] -> TypeSearch +createTypeSearch :: Aliases -> Instances -> [Link Entry] -> TypeSearch createTypeSearch aliases instances xs = TypeSearch $ newGraphs aliases instances types - where types = [(e, sig) | (ItemFunc _ sig, Just e) <- xs] + where types = [(x, fromDefer sig) | x <- xs, Just sig <- [entryTypesig $ fromLink x]] --------------------------------------------------------------------- diff --git a/src/Hoogle/DataBase/TypeSearch/Binding.hs b/src/Hoogle/DataBase/TypeSearch/Binding.hs --- a/src/Hoogle/DataBase/TypeSearch/Binding.hs +++ b/src/Hoogle/DataBase/TypeSearch/Binding.hs @@ -1,6 +1,8 @@ {-| Deal with variable bindings/alpha renaming in searches And with restrictions + + Deals with how the query is mapped to the result -} module Hoogle.DataBase.TypeSearch.Binding( @@ -117,4 +119,4 @@ bindings :: Binding -> [(Type, Type)] bindings (Binding _ _ a b) = [(TVar v, t) | (v,(l,vs)) <- Map.toList a, t <- [TLit l | Just l <- [l]] ++ map TVar (Set.toList vs)] ++ - [(TVar v, TLit l) | (v,(Just l,_)) <- Map.toList b] + [(TLit l, TVar v) | (v,(Just l,_)) <- Map.toList b] diff --git a/src/Hoogle/DataBase/TypeSearch/Cost.hs b/src/Hoogle/DataBase/TypeSearch/Cost.hs --- a/src/Hoogle/DataBase/TypeSearch/Cost.hs +++ b/src/Hoogle/DataBase/TypeSearch/Cost.hs @@ -21,6 +21,7 @@ | CostInstanceDel | CostInstanceAdd | CostDeadArg + | CostArgReorder deriving (Show,Eq,Ord,Enum,Bounded) @@ -40,3 +41,4 @@ cost CostInstanceDel = 4 -- 4..999 cost CostInstanceAdd = 4 -- 4..999 cost CostDeadArg = 3 -- 3..998 +cost CostArgReorder = 1 -- 1..1000 diff --git a/src/Hoogle/DataBase/TypeSearch/Graph.hs b/src/Hoogle/DataBase/TypeSearch/Graph.hs --- a/src/Hoogle/DataBase/TypeSearch/Graph.hs +++ b/src/Hoogle/DataBase/TypeSearch/Graph.hs @@ -24,8 +24,6 @@ import qualified Data.Heap as Heap import General.Code import Data.Key -import qualified Data.Binary.Defer.Graph as G -import Data.Binary.Defer.Graph hiding (Graph, Graph_) diff --git a/src/Hoogle/DataBase/TypeSearch/Result.hs b/src/Hoogle/DataBase/TypeSearch/Result.hs --- a/src/Hoogle/DataBase/TypeSearch/Result.hs +++ b/src/Hoogle/DataBase/TypeSearch/Result.hs @@ -83,8 +83,9 @@ newGraphsResults :: Instances -> EntryInfo -> Link EntryInfo -> [ResultArg] -> ResultArg -> Maybe Result newGraphsResults is query e args res = do b <- mergeBindings $ map resultArgBind $ args ++ [res] - let s = newTypeScore is query (fromLink e) b - view = zipWith ArgPosNum [0..] $ map resultArgPos args + let aps = map resultArgPos args + s = newTypeScore is query (fromLink e) (aps == sort aps) b + view = zipWith ArgPosNum [0..] aps -- need to fake at least one ArgPosNum, so we know we have some highlight info view2 = [ArgPosNum (-1) (-1) | null view] ++ view return (e, view2, s) diff --git a/src/Hoogle/DataBase/TypeSearch/TypeScore.hs b/src/Hoogle/DataBase/TypeSearch/TypeScore.hs --- a/src/Hoogle/DataBase/TypeSearch/TypeScore.hs +++ b/src/Hoogle/DataBase/TypeSearch/TypeScore.hs @@ -16,6 +16,7 @@ data TypeScore = TypeScore {costTypeScore :: !Int ,badargs :: Int + ,badorder :: Bool ,bind :: Binding ,badInstance :: (TypeContext, TypeContext) ,badAlias :: ([String], [String]) @@ -26,6 +27,7 @@ show t = unwords $ ['#' : show (costTypeScore t)] ++ replicate (badargs t) "badarg" ++ + ["badorder" | badorder t] ++ [show $ bind t] ++ both inst (badInstance t) ++ both alis (badAlias t) @@ -42,11 +44,12 @@ compare = compare `on` costTypeScore -newTypeScore :: Instances -> EntryInfo -> EntryInfo -> Binding -> TypeScore -newTypeScore is query result bs = t{costTypeScore = calcScore t} +newTypeScore :: Instances -> EntryInfo -> EntryInfo -> Bool -> Binding -> TypeScore +newTypeScore is query result inorder bs = t{costTypeScore = calcScore t} where t = TypeScore 0 (entryInfoArity result - entryInfoArity query) + (not inorder) bs (entryInfoContext query `diff` ctx) (entryInfoAlias query `diff` entryInfoAlias result) @@ -64,6 +67,7 @@ costsTypeScoreLocal :: TypeScore -> [Cost] costsTypeScoreLocal t = CostDeadArg *+ badargs t ++ + [CostArgReorder | badorder t] ++ CostAliasFwd *+ length (fst $ badAlias t) ++ CostAliasBwd *+ length (snd $ badAlias t) ++ CostInstanceAdd *+ length (fst $ badInstance t) ++ diff --git a/src/Hoogle/Item/All.hs b/src/Hoogle/Item/All.hs --- a/src/Hoogle/Item/All.hs +++ b/src/Hoogle/Item/All.hs @@ -1,8 +1,10 @@ module Hoogle.Item.All( module Hoogle.Item.Item, - module Hoogle.Item.Haddock + module Hoogle.Item.Haddock, + module Hoogle.Item.URL ) where import Hoogle.Item.Item import Hoogle.Item.Haddock +import Hoogle.Item.URL diff --git a/src/Hoogle/Item/Haddock.hs b/src/Hoogle/Item/Haddock.hs --- a/src/Hoogle/Item/Haddock.hs +++ b/src/Hoogle/Item/Haddock.hs @@ -6,10 +6,10 @@ import General.Code import Data.TagStr import Data.Binary.Defer -import Data.Binary.Defer.Vector +import Data.ByteString.Char8(ByteString,pack,unpack) -newtype Haddock = Haddock (Vector Char) +newtype Haddock = Haddock ByteString instance BinaryDefer Haddock where @@ -17,11 +17,11 @@ get = get1 Haddock -newHaddock = Haddock . fromList +newHaddock = Haddock . pack renderHaddock :: Haddock -> TagStr -renderHaddock (Haddock xs) = Tags $ f False $ parseHaddock $ toList xs +renderHaddock (Haddock xs) = Tags $ f False $ parseHaddock $ unpack xs where nl = Char '\n' @@ -31,11 +31,14 @@ f True (Char '\n':xs) = Str "\n" : Str "> " : f True xs + -- TODO: tt is ignored, add a TagMonospage? f pre (Tag "tt" x:xs) = f pre (x++xs) f pre (Tag [t,'l'] x:xs) | t `elem` "ou" = tail $ f pre (filter (/= nl) x ++ xs) f pre (Tag "pre" x:xs) = init (init $ tail $ f True x) ++ f pre xs f pre (Tag "li" x:xs) = Str "\n" : Str "* " : f pre x ++ f pre xs - f pre (Tag "a" x:xs) = TagUnderline (Tags $ f pre x) : f pre xs + f pre (Tag "a" x:xs) = TagHyperlink "" (Tags $ f pre x) : f pre xs + f pre (Tag "i" x:xs) = TagUnderline (Tags $ f pre x) : f pre xs + f pre (Tag "b" x:xs) = TagBold (Tags $ f pre x) : f pre xs f pre (Tag n x:xs) = Str (show (Tag n x)) : f pre xs f pre (Char x:xs) = Str [x] : f pre xs diff --git a/src/Hoogle/Item/Item.hs b/src/Hoogle/Item/Item.hs --- a/src/Hoogle/Item/Item.hs +++ b/src/Hoogle/Item/Item.hs @@ -16,7 +16,7 @@ {packageName :: String ,packageVersion :: String ,haddockURL :: String - ,hscolourURL :: String + ,hackageURL :: String } typename_Package = mkTyCon "Hoogle.DataBase.Item.Package" @@ -25,22 +25,27 @@ data Module = Module {moduleName :: [String] - ,modulePackage :: Link Package } typename_Module = mkTyCon "Hoogle.DataBase.Item.Module" instance Typeable Module where typeOf _ = mkTyConApp typename_Module [] +-- TODO: Is entryName every used? Can it make use of the invariant? +-- Perhaps just store the entryText, then regenerate entryName at load time + -- invariant: entryName == head [i | Focus i <- entryText] data Entry = Entry {entryModule :: Maybe (Link Module) + ,entryPackage :: Link Package ,entryName :: String ,entryText :: [EntryText] ,entryType :: EntryType ,entryDocs :: Haddock + ,entryTypesig :: Maybe (Defer TypeSig) } + typename_Entry = mkTyCon "Hoogle.DataBase.Item.Entry" instance Typeable Entry where typeOf _ = mkTyConApp typename_Entry [] @@ -57,10 +62,15 @@ deriving Show data EntryType = EntryModule + | EntryPackage | EntryKeyword | EntryOther deriving (Eq,Enum,Show) + +-- TODO: EntryScore is over-prescriptive, and not overly useful +-- Have name and type scores to it themselves, using name only +-- to break ties when merging -- the number of elements in the module name -- the name of the entry, in lower case -- the name of the entry @@ -71,7 +81,8 @@ entryScore :: Entry -> EntryScore entryScore e = EntryScore - (length m) (map toLower $ entryName e) (entryName e) m + (if entryType e == EntryOther then length m else 0) + (map toLower $ entryName e) (entryName e) m where m = maybe [] (moduleName . fromLink) $ entryModule e @@ -104,14 +115,17 @@ renderTextItem :: TextItem -> [EntryText] renderTextItem x = case x of ItemClass i -> [Keyword "class", Text " "] ++ typeHead i - ItemFunc name typ -> [Focus name, Text " :: "] ++ renderTypeSig typ + ItemFunc name typ -> operator name ++ [Text " :: "] ++ renderTypeSig typ ItemAlias a b -> [Keyword "type", Text " "] ++ typeHead a ++ [Text $ " = " ++ show b] ItemData d t -> [Keyword (show d), Text " "] ++ typeHead t where typeHead (TypeSig con sig) = [Text $ showConstraint con, Focus a, Text b] where (a,b) = break (== ' ') $ show sig + operator xs@(x:_) | not $ isAlpha x || x `elem` "#_'" = [Text "(",Focus xs,Text ")"] + operator xs = [Focus xs] + renderTypeSig :: TypeSig -> [EntryText] renderTypeSig (TypeSig con sig) = Text (showConstraint con) : intersperse (Text " -> ") (zipWith ArgPos [0..] a ++ [ArgRes b]) @@ -121,15 +135,15 @@ showModule = concat . intersperse "." instance Show Package where - show (Package a b c d) = unwords [a,b,c,d] + show (Package a b c d) = unwords $ filter (/= "") [a,b,c,d] instance Show Module where - show (Module a b) = unwords [showModule a, "{" ++ show b ++ "}"] + show (Module a) = showModule a instance Show Entry where - show (Entry a _ b _ _) = unwords [concatMap f b, m] + show e = unwords [concatMap f $ entryText e, m] where - m = case a of + m = case entryModule e of Nothing -> "" Just y -> "{#" ++ show (linkKey y) ++ "}" @@ -145,12 +159,12 @@ get = get4 Package instance BinaryDefer Module where - put (Module a b) = put2 a b - get = get2 Module + put (Module a) = put1 a + get = get1 Module instance BinaryDefer Entry where - put (Entry a b c d e) = put5 a b c d e - get = get5 Entry + put (Entry a b c d e f g) = put7 a b c d e f g + get = get7 Entry instance BinaryDefer EntryText where put (Keyword a) = putByte 0 >> put1 a @@ -168,5 +182,6 @@ 4 -> get1 ArgRes instance BinaryDefer EntryType where - put = put . fromEnum - get = liftM toEnum get + put = putEnumByte + get = getEnumByte + diff --git a/src/Hoogle/Item/URL.hs b/src/Hoogle/Item/URL.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Item/URL.hs @@ -0,0 +1,34 @@ + +module Hoogle.Item.URL where + +import General.Code +import Hoogle.Item.Item +import Web.Text(escapeHTML) -- TODO: Shouldn't be importing this! +import Numeric +import Data.Binary.Defer.Index + + + +entryURL :: Entry -> String +entryURL e@Entry{entryType=EntryModule} = entryModuleURL e +entryURL e@Entry{entryType=EntryPackage} = entryPackageURL e +entryURL e@Entry{entryType=EntryOther} = entryModuleURL e ++ "#v:" ++ escapeHTML (entryName e) +entryURL e@Entry{entryType=EntryKeyword} = + "http://www.haskell.org/haskellwiki/Keywords#" ++ concatMap f (entryName e) + where + f x | isAlpha x || x `elem` "_-:" = [x] + | otherwise = '.' : map toUpper (showHex (ord x) "") + + +entryModuleURL :: Entry -> String +entryModuleURL Entry{entryModule=Just m, entryPackage=p} | pkg /= "" = + pkg ++ concat (intersperse "-" name) ++ ".html" + where + name = moduleName $ fromLink m + pkg = haddockURL $ fromLink p +entryModuleURL _ = "" + + +entryPackageURL :: Entry -> String +entryPackageURL e = if a == "" then b else a + where Package{hackageURL=a, haddockURL=b} = fromLink $ entryPackage e diff --git a/src/Hoogle/Operations/All.hs b/src/Hoogle/Operations/All.hs --- a/src/Hoogle/Operations/All.hs +++ b/src/Hoogle/Operations/All.hs @@ -1,8 +1,10 @@ module Hoogle.Operations.All( + module Hoogle.Operations.Combine, module Hoogle.Operations.Convert, module Hoogle.Operations.Rank ) where +import Hoogle.Operations.Combine import Hoogle.Operations.Convert import Hoogle.Operations.Rank diff --git a/src/Hoogle/Operations/Combine.hs b/src/Hoogle/Operations/Combine.hs new file mode 100644 --- /dev/null +++ b/src/Hoogle/Operations/Combine.hs @@ -0,0 +1,11 @@ + +module Hoogle.Operations.Combine(combine) where + +import General.Code +import Hoogle.DataBase.All + + +combine :: [FilePath] -> FilePath -> IO () +combine infiles outfile = do + dbs <- mapM loadDataBase infiles + saveDataBase outfile $ combineDataBase dbs diff --git a/src/Hoogle/Operations/Convert.hs b/src/Hoogle/Operations/Convert.hs --- a/src/Hoogle/Operations/Convert.hs +++ b/src/Hoogle/Operations/Convert.hs @@ -7,13 +7,14 @@ -- error messages are given using trace and error -convert :: Bool -> FilePath -> FilePath -> IO () -convert debugCheck tb db = do +convert :: Bool -> [FilePath] -> FilePath -> FilePath -> IO () +convert debugCheck deps tb db = do res <- parseTextBase tb case res of Left x -> error $ show x Right x -> do - let y = createDataBase x + dbs <- mapM loadDataBase deps + let y = createDataBase dbs x saveDataBase db y when (debugCheck) $ do diff --git a/src/Hoogle/Operations/Rank.hs b/src/Hoogle/Operations/Rank.hs --- a/src/Hoogle/Operations/Rank.hs +++ b/src/Hoogle/Operations/Rank.hs @@ -55,8 +55,8 @@ xs2 = zip ["f" ++ show i | i <- [1..]] xs res = searchAll [db] q - db = createDataBase $ tb ++ [(ItemFunc a b, "") | (a,b) <- xs2] - q = defaultQuery{typeSig=Just t} + db = createDataBase [] $ tb ++ [(ItemFunc a b, "") | (a,b) <- xs2] + q = blankQuery{typeSig=Just t} grab :: (String,TypeSig) -> (TypeSig,[Cost]) grab (name,typ) = (,) typ $ diff --git a/src/Hoogle/Query/Parser.hs b/src/Hoogle/Query/Parser.hs --- a/src/Hoogle/Query/Parser.hs +++ b/src/Hoogle/Query/Parser.hs @@ -22,12 +22,10 @@ | otherwise = x -blank = Query [] [] Nothing [] [] - -merge (Query a1 b1 c1 d1 e1) (Query a2 b2 c2 d2 e2) = - Query (a1++a2) (b1++b2) (c1 `mplus` c2) (d1++d2) (e1++e2) +merge (Query a1 b1 c1 d1) (Query a2 b2 c2 d2) = + Query (a1++a2) (b1++b2) (c1 `mplus` c2) (d1++d2) -merges xs = foldr merge blank xs +merges xs = foldr merge blankQuery xs parsecQuery :: Parser Query @@ -36,15 +34,19 @@ end f = do x <- f; eof; return x names = do a <- many (flag <|> name) - b <- option blank (string "::" >> spaces >> types) - return (merge (merges a) b) + b <- option blankQuery (string "::" >> spaces >> types) + let res@Query{names=names} = merge (merges a) b + (op,nop) = partition ((`elem` ascSymbols) . head) names + if op /= [] && nop /= [] + then fail "Combination of operators and names" + else return res - name = (do x <- operator ; spaces ; return blank{names=[x]}) + name = (do x <- operator ; spaces ; return blankQuery{names=[x]}) <|> (do xs <- keyword `sepBy1` (char '.') ; spaces return $ case xs of - [x] -> blank{names=[x]} - xs -> blank{names=[last xs],scope=[PlusModule (init xs)]} + [x] -> blankQuery{names=[x]} + xs -> blankQuery{names=[last xs],scope=[PlusModule (init xs)]} ) operator = between (char '(') (char ')') op <|> op @@ -54,8 +56,8 @@ types = do a <- flags b <- parsecTypeSig c <- flags - return $ merges [a,blank{typeSig=Just b},c] - + return $ merges [a,blankQuery{typeSig=Just b},c] + flag = do x <- parseFlagScope ; spaces ; return x flags = many flag >>= return . merges @@ -67,7 +69,7 @@ -- /? (special case) -- +Data.Map parseFlagScope :: Parser Query -parseFlagScope = do x <- try scope <|> flag +parseFlagScope = do x <- try scope <|> try flag spaces return x where @@ -76,7 +78,7 @@ flag = do string "--" <|> string "/" name <- many1 letter <|> string "?" extra <- (do char '='; flagExtra) <|> (return "") - return blank{flags=[Flag (map toLower name) extra]} + return blankQuery{flags=[Flag (map toLower name) extra]} where flagExtra = quoteStr <|> spaceStr quoteStr = between (char '\"') (char '\"') (many anyChar) @@ -87,13 +89,14 @@ aModule = if pm == '+' then PlusModule else MinusModule modu <- modname case modu of - [x] -> return $ blank{scope=[if isLower (head x) then aPackage x else aModule [x]]} - xs -> return $ blank{scope=[aModule xs]} + [x] -> return $ blankQuery{scope=[if isLower (head x) then aPackage x else aModule [x]]} + xs -> return $ blankQuery{scope=[aModule xs]} modname = keyword `sepBy1` (char '.') +-- TODO: Should share this definition with Hoogle.TypeSig.Parser keyword = do x <- letter - xs <- many $ satisfy (\x -> isAlphaNum x || x == '_') + xs <- many $ satisfy (\x -> isAlphaNum x || x `elem` "_'#") return (x:xs) diff --git a/src/Hoogle/Query/Render.hs b/src/Hoogle/Query/Render.hs --- a/src/Hoogle/Query/Render.hs +++ b/src/Hoogle/Query/Render.hs @@ -3,6 +3,7 @@ import General.Code import Data.TagStr +import Data.Generics.Uniplate import Hoogle.Query.Type import Hoogle.TypeSig.All @@ -12,9 +13,11 @@ where namesig = case (null (names x), isNothing (typeSig x)) of (True, True) -> [] - (True, False) -> showType + (True, False) -> [Str ":: " | namelike] ++ showType (False, True) -> showName _ -> showName ++ [Str " :: "] ++ showType + where namelike = and [isAlpha y || isSpace y | Str xs <- universe $ Tags showType + , y:ys <- [dropWhile isSpace xs]] showName = intersperse (Str " ") $ map (TagBold . Str) (names x) showType = Str (showConstraint con) : diff --git a/src/Hoogle/Query/Suggest.hs b/src/Hoogle/Query/Suggest.hs --- a/src/Hoogle/Query/Suggest.hs +++ b/src/Hoogle/Query/Suggest.hs @@ -5,19 +5,53 @@ import General.Code import Hoogle.DataBase.All import Hoogle.Query.Type +import Hoogle.Query.Render +import Hoogle.TypeSig.All suggestQuery :: [DataBase] -> Query -> Maybe TagStr + +-- They searched for Google (pay homage) suggestQuery db q | "google" `elem` map (map toLower) (names q) = Just $ Tags [TagHyperlink "http://www.google.com/" (Str "Google"), Str " rocks!"] +-- They searched for ?oogle (mock) suggestQuery db q | any f (names q) = Just $ Str "Can't think of anything more interesting to search for?" where f x = length x == 6 && "oogle" `isSuffixOf` x -suggestQuery db q | isJust $ typeSig q = - case suggestion db (fromJust $ typeSig q) of +-- They searched for "Int to Float", they meant "Int -> Float" +suggestQuery db q@Query{typeSig=Nothing, names=names} | "to" `elem` names = Just $ didYouMean q2 + where q2 = fixup db $ q{names = [] ,typeSig = Just $ TypeSig [] t2} + t2 = TFun $ map (toApp . map toLitVar) $ split "to" $ names + +-- They search for "Maybe a", did they mean ":: Maybe a" +suggestQuery db q@Query{typeSig=Nothing, names=names} | length names > 1 && all f names = Just $ didYouMean q2 + where q2 = fixup db $ q{names = [], typeSig = Just $ TypeSig [] $ toApp $ map toLitVar names} + f (x:xs) = if null xs then isLower x else isUpper x + +-- See what the type signature suggests from the database +suggestQuery db q@Query{typeSig=Just t} = + case suggestion db t of Nothing -> Nothing - Just (Left s) -> Just $ Str s - Just (Right t) -> Just $ Str $ "Did you mean: " ++ show t + Just (Left s) -> Just $ TagBold $ Str s + Just (Right t) -> Just $ didYouMean $ q{typeSig = Just t} suggestQuery db q = Nothing + + + +didYouMean :: Query -> TagStr +didYouMean q = Tags [TagBold $ Str "Did you mean: ", TagHyperlink ("query:" ++ s) $ Str s] + where s = showTagText $ renderQuery q + + +fixup :: [DataBase] -> Query -> Query +fixup db q@Query{typeSig=Just t} = + case suggestion db t of + Just (Right t) -> q{typeSig=Just t} + _ -> q +fixup db q = q + + +toLitVar xs@(x:_) = if isLower x then TVar xs else TLit xs +toApp (x:xs) = TApp x xs diff --git a/src/Hoogle/Query/Type.hs b/src/Hoogle/Query/Type.hs --- a/src/Hoogle/Query/Type.hs +++ b/src/Hoogle/Query/Type.hs @@ -12,21 +12,20 @@ usefulQuery query = not (null (names query)) || isJust (typeSig query) -defaultQuery = Query [] [] Nothing [] [] +blankQuery = Query [] [] Nothing [] data Query = Query { scope :: [Scope], names :: [String], typeSig :: Maybe TypeSig, - items :: [ItemType], flags :: [Flag] } deriving Show instance Eq Query where - (Query a1 b1 c1 d1 e1) == (Query a2 b2 c2 d2 e2) = - and [a1 `setEq` a2, b1 `setEq` b2, c1 == c2, d1 `setEq` d2, e1 `setEq` e2] + (Query a1 b1 c1 d1) == (Query a2 b2 c2 d2) = + and [a1 `setEq` a2, b1 `setEq` b2, c1 == c2, d1 `setEq` d2] data Scope = PlusPackage String @@ -37,20 +36,6 @@ isPlusModule (PlusModule _) = True; isPlusModule _ = False isMinusModule (MinusModule _) = True; isMinusModule _ = False - - -data ItemType = ItemModule - | ItemType - | ItemFunction - | ItemClass - deriving (Eq, Show, Read) - -itemTypes = - [(["module"], ItemModule) - ,(["type","data"], ItemType) - ,(["function","ctor","fun"], ItemFunction) - ,(["class","instance"], ItemClass) - ] -- primarily for consoles, but some work on the web search diff --git a/src/Hoogle/Search/Results.hs b/src/Hoogle/Search/Results.hs --- a/src/Hoogle/Search/Results.hs +++ b/src/Hoogle/Search/Results.hs @@ -60,20 +60,20 @@ filterResults q = f mods correctModule . f pkgs correctPackage where f [] act = id - f xs act = filter (maybe True (act xs . fromLink) . entryModule . fromLink . resultEntry) + f xs act = filter (act xs . fromLink . resultEntry) mods = filter (\x -> isPlusModule x || isMinusModule x) $ scope q pkgs = [x | MinusPackage x <- scope q] -- pkgs is a non-empty list of MinusPackage values -correctPackage :: [String] -> Module -> Bool -correctPackage pkgs = (`notElem` pkgs) . packageName . fromLink . modulePackage +correctPackage :: [String] -> Entry -> Bool +correctPackage pkgs = (`notElem` pkgs) . packageName . fromLink . entryPackage -- mods is a non-empty list of PlusModule/MinusModule -correctModule :: [Scope] -> Module -> Bool -correctModule mods = f base mods . moduleName +correctModule :: [Scope] -> Entry -> Bool +correctModule mods = maybe True (f base mods . moduleName . fromLink) . entryModule where base = isMinusModule $ head mods diff --git a/src/Hoogle/TextBase/Parser.hs b/src/Hoogle/TextBase/Parser.hs --- a/src/Hoogle/TextBase/Parser.hs +++ b/src/Hoogle/TextBase/Parser.hs @@ -24,8 +24,7 @@ f com [] = [] f com ((i,s):is) | "-- | " `isPrefixOf` s = f [drop 5 s] is - | "-- " `isPrefixOf` s && com /= [] = f (drop 5 s:com) is - | "-- " `isPrefixOf` s = f [] is + | "--" `isPrefixOf` s = f ([drop 5 s | com /= []] ++ com) is | all isSpace s = f [] is | otherwise = (case parse parsecTextItem file s of Left y -> Left $ setErrorPos (setSourceLine (errorPos y) i) y diff --git a/src/Hoogle/TextBase/Type.hs b/src/Hoogle/TextBase/Type.hs --- a/src/Hoogle/TextBase/Type.hs +++ b/src/Hoogle/TextBase/Type.hs @@ -2,6 +2,8 @@ module Hoogle.TextBase.Type where import Hoogle.TypeSig.All +import Data.Binary.Defer +import General.Code -- (the item, any haddock documentation) @@ -19,8 +21,34 @@ data DataKeyword = NewTypeKeyword | DataKeyword - deriving Eq + deriving (Enum,Eq) instance Show DataKeyword where show NewTypeKeyword = "newtype" show DataKeyword = "data" + + +instance BinaryDefer TextItem where + put (ItemModule a ) = putByte 0 >> put1 a + put (ItemClass a ) = putByte 1 >> put1 a + put (ItemFunc a b) = putByte 2 >> put2 a b + put (ItemAlias a b) = putByte 3 >> put2 a b + put (ItemData a b) = putByte 4 >> put2 a b + put (ItemInstance a ) = putByte 5 >> put1 a + put (ItemAttribute a b) = putByte 6 >> put2 a b + + get = do + x <- getByte + case x of + 0 -> get1 ItemModule + 1 -> get1 ItemClass + 2 -> get2 ItemFunc + 3 -> get2 ItemAlias + 4 -> get2 ItemData + 5 -> get1 ItemInstance + 6 -> get2 ItemAttribute + + +instance BinaryDefer DataKeyword where + put = putEnumByte + get = getEnumByte diff --git a/src/Hoogle/TypeSig/Parser.hs b/src/Hoogle/TypeSig/Parser.hs --- a/src/Hoogle/TypeSig/Parser.hs +++ b/src/Hoogle/TypeSig/Parser.hs @@ -20,7 +20,7 @@ context = try acontext <|> return [] acontext = do x <- conitems <|> (conitem >>= return . (:[])) - white $ string "=>" + white $ char '=' >> oneOf "#>" return x conitems = between (wchar '(') (wchar ')') $ conitem `sepBy1` (wchar ',') @@ -98,9 +98,11 @@ keysymbol = try $ do x <- many1 $ satisfy (\x -> isSymbol x || x `elem` ascSymbol) - if x `elem` ["::","=>",".","=","#",":","-","+","/","--"] then fail "Bad symbol" else - return $ if x == "-#" then "->" else x - ascSymbol = "!#$%&*+./<=>?@\\^|-~:" + if x `elem` ["->","-#"] then return "->" -- fast shortcut for arrows + else if x `elem` reservedSym then fail "Bad symbol" + else return x + ascSymbol = "->#!$%&*+./<=?@\\^|-~:" + reservedSym = ["::","=>","=#",".","=","#",":","-","+","/","--"] optionBool p = (p >> return True) <|> return False diff --git a/src/Hoogle/TypeSig/Type.hs b/src/Hoogle/TypeSig/Type.hs --- a/src/Hoogle/TypeSig/Type.hs +++ b/src/Hoogle/TypeSig/Type.hs @@ -80,18 +80,25 @@ --------------------------------------------------------------------- -- UNIPLATE INSTANCES -onTypeSig :: BiplateType TypeSig Type -onTypeSig (TypeSig xs x) = (x:xs, \(x:xs) -> TypeSig xs x) - instance Uniplate Type where uniplate (TApp x xs) = (x:xs, \(x:xs) -> TApp x xs) uniplate (TFun xs) = (xs, \xs -> TFun xs) uniplate x = ([], \[] -> x) +onTypeSig :: BiplateType TypeSig Type +onTypeSig (TypeSig xs x) = (x:xs, \(x:xs) -> TypeSig xs x) + +transformSig = transformOn onTypeSig +universeSig = universeOn onTypeSig + + variables :: Type -> [String] variables x = [v | TVar v <- universe x] +variablesSig :: TypeSig -> [String] +variablesSig x = [v | TVar v <- universeSig x] + --------------------------------------------------------------------- -- BINARYDEFER INSTANCES @@ -127,10 +134,18 @@ instance Show Type where showsPrec i x = showString $ f i x where + -- Show lists and tuples specially f i (TApp (TLit "[]") [x]) = "[" ++ show x ++ "]" f i (TApp (TLit ('(':tup)) xs) | not (null tup) && last tup == ')' && all (== ',') (init tup) && length tup == length xs = b True $ concat $ intersperse ", " $ map show xs + + -- Should parallel lists and unboxed tuples specially + f i (TApp (TLit "[::]") [x]) = "[:" ++ show x ++ ":]" + f i (TApp (TLit ('(':'#':tup)) xs) + | "#)" `isSuffixOf` tup && all (== ',') (drop 2 $ reverse tup) && length tup - 1 == length xs + = "(# " ++ (concat $ intersperse ", " $ map show xs) ++ " #)" + f i (TLit x) = x f i (TVar x) = x diff --git a/src/Test/Parse_Query.hs b/src/Test/Parse_Query.hs --- a/src/Test/Parse_Query.hs +++ b/src/Test/Parse_Query.hs @@ -7,21 +7,30 @@ parse_Query = do let (===) = parseTest parseQuery + q = blankQuery - "/info" === defaultQuery{flags = [Flag "info" ""]} - "--info" === defaultQuery{flags = [Flag "info" ""]} - "/?" === defaultQuery{flags = [Flag "?" ""]} - "/count=10" === defaultQuery{flags = [Flag "count" "10"]} - "map" === defaultQuery{names = ["map"]} - "concat map" === defaultQuery{names = ["concat","map"]} - "a -> b" === defaultQuery{typeSig = Just (TypeSig [] (TFun [TVar "a",TVar "b"]))} - "(a b)" === defaultQuery{typeSig = Just (TypeSig [] (TApp (TVar "a") [TVar "b"]))} - "map :: a -> b" === defaultQuery{names = ["map"], typeSig = Just (TypeSig [] (TFun [TVar "a",TVar "b"]))} - "+Data.Map map" === defaultQuery{scope = [PlusModule ["Data","Map"]], names = ["map"]} - "a -> b +foo" === defaultQuery{scope = [PlusPackage "foo"], typeSig = Just (TypeSig [] (TFun [TVar "a",TVar "b"]))} - "a -> b /foo" === defaultQuery{flags = [Flag "foo" ""], typeSig = Just (TypeSig [] (TFun [TVar "a",TVar "b"]))} - "a -> b --foo" === defaultQuery{flags = [Flag "foo" ""], typeSig = Just (TypeSig [] (TFun [TVar "a",TVar "b"]))} - "Data.Map.map" === defaultQuery{scope = [PlusModule ["Data","Map"]], names = ["map"]} - "[a]" === defaultQuery{typeSig = Just (TypeSig [] (TApp (TLit "[]") [TVar "a"]))} - "++" === defaultQuery{names = ["++"]} - "(++)" === defaultQuery{names = ["++"]} + "/info" === q{flags = [Flag "info" ""]} + "--info" === q{flags = [Flag "info" ""]} + "/?" === q{flags = [Flag "?" ""]} + "/count=10" === q{flags = [Flag "count" "10"]} + "map" === q{names = ["map"]} + "#" === q{names = ["#"]} + "c#" === q{names = ["c#"]} + "-" === q{names = ["-"]} + "/" === q{names = ["/"]} + "->" === q{names = ["->"]} + "foldl'" === q{names = ["foldl'"]} + "fold'l" === q{names = ["fold'l"]} + "Int#" === q{names = ["Int#"]} + "concat map" === q{names = ["concat","map"]} + "a -> b" === q{typeSig = Just (TypeSig [] (TFun [TVar "a",TVar "b"]))} + "(a b)" === q{typeSig = Just (TypeSig [] (TApp (TVar "a") [TVar "b"]))} + "map :: a -> b" === q{names = ["map"], typeSig = Just (TypeSig [] (TFun [TVar "a",TVar "b"]))} + "+Data.Map map" === q{scope = [PlusModule ["Data","Map"]], names = ["map"]} + "a -> b +foo" === q{scope = [PlusPackage "foo"], typeSig = Just (TypeSig [] (TFun [TVar "a",TVar "b"]))} + "a -> b /foo" === q{flags = [Flag "foo" ""], typeSig = Just (TypeSig [] (TFun [TVar "a",TVar "b"]))} + "a -> b --foo" === q{flags = [Flag "foo" ""], typeSig = Just (TypeSig [] (TFun [TVar "a",TVar "b"]))} + "Data.Map.map" === q{scope = [PlusModule ["Data","Map"]], names = ["map"]} + "[a]" === q{typeSig = Just (TypeSig [] (TApp (TLit "[]") [TVar "a"]))} + "++" === q{names = ["++"]} + "(++)" === q{names = ["++"]} diff --git a/src/Test/Parse_TypeSig.hs b/src/Test/Parse_TypeSig.hs --- a/src/Test/Parse_TypeSig.hs +++ b/src/Test/Parse_TypeSig.hs @@ -36,6 +36,7 @@ "Eq a => a" === TypeSig [TApp (TLit "Eq") [TVar "a"]] (TVar "a") "Class a b => a b" === TypeSig [TApp (TLit "Class") [TVar "a",TVar "b"]] (TApp (TVar "a") [TVar "b"]) "(Ord a, Eq b) => a -> b" === TypeSig [TApp (TLit "Ord") [TVar "a"],TApp (TLit "Eq") [TVar "b"]] (TFun [TVar "a",TVar "b"]) + "Eq a =# a" === TypeSig [TApp (TLit "Eq") [TVar "a"]] (TVar "a") -- forall "forall a . a -> a" === TypeSig [] (TFun [TVar "a", TVar "a"]) diff --git a/src/Web/Action.hs b/src/Web/Action.hs --- a/src/Web/Action.hs +++ b/src/Web/Action.hs @@ -6,24 +6,66 @@ import Hoogle.Query.All import Hoogle.Item.All import Hoogle.Search.All +import Numeric import General.Code import System.IO.Unsafe(unsafeInterleaveIO) import Web.Page +import Web.Text import Text.ParserCombinators.Parsec import Data.TagStr import Data.Range import Data.Binary.Defer.Index +import Data.Generics.Uniplate +import Data.Time.Clock +import Data.Time.Calendar +import General.CGI(cgiArgs) +import Paths_hoogle + actionWeb :: CmdQuery -> IO () actionWeb q = do - (skipped,dbs) <- loadDataBases q - let res = unlines $ header (escapeHTML $ queryText q) ++ runQuery dbs q ++ footer + logMessage q + res <- + if Mode "suggest" `elem` queryFlags q then do + putStr "Content-type: application/json\n\n" + runSuggest q + else do + putStr "Content-type: text/html\n\n" + (skipped,dbs) <- loadDataBases q + return $ unlines $ header (escapeHTML $ queryText $ queryPretty q) ++ runQuery dbs q ++ footer + putStrLn res when (Debug `elem` queryFlags q) $ writeFile "temp.htm" res - putStrLn res + sequence_ [writeFile x res | Output x <- queryFlags q] +-- TODO: Hacky, requires a better parser +-- Strip out Web, Debug and Output from queryText +queryPretty :: CmdQuery -> CmdQuery +queryPretty q = q{queryText = unwords $ filter f $ words $ queryText q} + where f x = not $ any (`isPrefixOf` x) ["/debug","/output","/web"] + + +logMessage :: CmdQuery -> IO () +logMessage q = do + time <- getCurrentTime + cgi <- liftM (fromMaybe []) $ cgiArgs + appendFile "log.txt" $ (++ "\n") $ unwords $ + [showGregorian (utctDay time) + ,show (queryText q)] ++ + ["?" ++ a ++ "=" ++ c ++ b ++ c | (a,b) <- cgi, let c = ['\"' | any isSpace b]] + + +runSuggest :: CmdQuery -> IO String +runSuggest CmdQuery{query=Right Query{scope=[], names=[x], typeSig=Nothing}} = do + root <- getDataDir + db <- loadDataBase $ root "default.hoo" + let res = take 8 $ completions db x + return $ "[" ++ show x ++ "," ++ show res ++ "]" +runSuggest _ = return "" + + -- is the package not something that might go wrong safePackage :: String -> Bool safePackage = all $ \x -> isAlphaNum x || x `elem` "-_" @@ -36,7 +78,8 @@ loadDataBases CmdQuery{query=Right q} = do let pkgs = nub [x | PlusPackage x <- scope q, safePackage x] files = if null pkgs then ["default"] else pkgs - files <- filterM doesFileExist $ map (\x -> "res" x <.> "hoo") files + root <- getDataDir + files <- filterM doesFileExist $ map (\x -> root x <.> "hoo") files dbs <- unsafeInterleaveIO $ mapM loadDataBase files return ([], dbs) loadDataBases _ = return ([], []) @@ -51,7 +94,8 @@ ,"

" ," Error: " +& drop 1 (dropWhile (/= ':') $ show err) ++ "
" ,"

" - ," For information on what queries should look like, see the user manual." + ," For information on what queries should look like, see the" + ," user manual." ,"

" ] where @@ -59,41 +103,40 @@ post2 = if null post then concat (replicate 3 " ") else post -runQuery dbs q | not $ usefulQuery $ fromRight $ query q = - ["

Welcome to Hoogle

" - ,"

" - ," Hoogle is a Haskell API search engine, have fun!" - ,"

" - ] +runQuery dbs q | not $ usefulQuery $ fromRight $ query q = welcome runQuery dbs cq@CmdQuery{query = Right q, queryFlags = flags} = ["

Searching for " ++ qstr ++ "

"] ++ - ["

" ++ showTagHTML sug ++ "

" | Just sug <- [suggestQuery dbs q]] ++ + ["

" ++ showTagHTML (transform qurl sug) ++ "

" | Just sug <- [suggestQuery dbs q]] ++ if null res then ["

No results found

"] - else -- error $ show (length res, length pre, length now, length post) - + else [""] ++ - concatMap renderRes pre ++ - insertMore (concatMap renderRes now) ++ + concatMap (uncurry renderRes) pre ++ + insertMore (concatMap (uncurry renderRes) now) ++ [moreResults | not $ null post] ++ ["
"] where start = headDef 0 [i-1 | Start i <- flags] count = headDef 20 [n | Count n <- flags] - res = searchRange (rangeStartCount 0 (start+count+1)) dbs q + res = zip [0..] $ searchRange (rangeStartCount 0 (start+count+1)) dbs q (pre,res2) = splitAt start res (now,post) = splitAt count res2 - moreResults = "Show more results" - urlMore = "?q=" +% queryText cq ++ "&start=" ++ show (start+count+1) ++ "#more" + moreResults = "Show more results" + urlMore = "?hoogle=" +% queryText cq ++ "&start=" ++ show (start+count+1) ++ "#more" qstr = unwords $ ["" +& n ++ "" | n <- names q] ++ ["::" | names q /= [] && isJust (typeSig q)] ++ [showTagHTML (renderEntryText view $ renderTypeSig t) | Just t <- [typeSig q]] view = [ArgPosNum i i | i <- [0..10]] + qurl (TagHyperlink url x) | "query:" `isPrefixOf` url = TagHyperlink ("?hoogle=" +% drop 6 url) x + qurl x = x + + -- insert where you can insertMore :: [String] -> [String] insertMore [] = [] @@ -104,60 +147,32 @@ f [] = [] -renderRes :: Result -> [String] -renderRes r = - [tr $ td "mod" modname ++ td "" (href urlItem $ showTagHTMLWith url text) - ,tr $ td "pkg" pkgname ++ td "doc" doc] +renderRes :: Int -> Result -> [String] +renderRes i r = + [tr $ modname ++ td "ans" (href urlEnt $ showTagHTMLWith url text) + ,tr $ pkgname ++ td "doc" docs] where - pkg = liftM (fromLink . modulePackage . fromLink) $ entryModule $ fromLink $ resultEntry r + ent = fromLink $ resultEntry r (modu,text,_) = renderResult r - modname = maybe "" (href urlModule . showModule) modu - pkgname = maybe "" (href urlPkg . packageName) pkg - doc = takeWhile (/= '\n') $ showTagHTML $ renderHaddock $ entryDocs $ fromLink $ resultEntry r + modname = td "mod" $ maybe "" (href urlMod . showModule) modu + pkgname = td "pkg" $ href urlPkg $ packageName $ fromLink $ entryPackage ent - urlPkg = "http://hackage.haskell.org/packages/archive/" +? maybe "" packageName pkg +? "/latest/doc/html/" - urlModule = urlPkg +? concat (intersperse "-" $ fromMaybe [] modu) +? ".html" - urlItem = urlModule +? "#v:" +? escapeHTML (entryName $ fromLink $ resultEntry r) + docs = ("
" ++ + "") +? + (showTagHTML $ renderHaddock $ entryDocs ent) +? + "
" - url (TagHyperlink _ x) = Just $ "" ++ showTagHTML x ++ - "" + urlPkg = entryPackageURL ent + urlMod = entryModuleURL ent + urlEnt = entryURL ent + + url (TagHyperlink _ x) + | null urlEnt = Just $ "" ++ showTagHTML x ++ "" + | otherwise = Just $ "" ++ showTagHTML x ++ + "" url _ = Nothing tr x = "" ++ x ++ "" td c x = "" ++ x ++ "" href url x = if null url then x else "" ++ x ++ "" - - --- | Only append strings if neither one is empty -(+?) :: String -> String -> String -a +? b = if null a || null b then [] else a ++ b - --- | Escape the second argument before appending -(+&) :: String -> String -> String -a +& b = a ++ escapeHTML b - -(+%) = (+&) -- CGI query string escaping - - -escapeHTML = concatMap f - where - f '\"' = """ - f '<' = "<" - f '>' = ">" - f x = [x] - - -showTagHTML = showTagHTMLWith (const Nothing) - - -showTagHTMLWith :: (TagStr -> Maybe String) -> TagStr -> String -showTagHTMLWith f x = g x - where - g x | isJust (f x) = fromJust $ f x - g (Str x) = escapeHTML x - g (Tags xs) = concatMap g xs - g (TagBold x) = "" ++ showTagHTML x ++ "" - g (TagUnderline x) = "" ++ showTagHTML x ++ "" - g (TagHyperlink url x) = "" ++ showTagHTML x ++ "" - g (TagColor i x) = "" ++ showTagHTML x ++ "" diff --git a/src/Web/Page.hs b/src/Web/Page.hs --- a/src/Web/Page.hs +++ b/src/Web/Page.hs @@ -1,15 +1,17 @@ -module Web.Page(header, footer) where +module Web.Page(header, footer, welcome) where +import Web.Text header query = ["" - ,"" - ," " + ,"" + ," " ," " - ," " ++ query ++ " - Hoogle" - ," " - ," " + ," " ++ (query +? " - ") ++ "Hoogle" + ," " + ," " + ," " ," " ," " ," " @@ -18,18 +20,21 @@ links = ["" ] search query = - ["" ] @@ -39,3 +44,32 @@ ," " ,"" ] + + +welcome = + ["

Welcome to Hoogle

" + ,"

" + ," Hoogle is a Haskell API search engine, which allows you to search many standard Haskell libraries" + ," by either function name, or by approximate type signature." + ,"

" + ,"

" + ," Example searches:
" + ," " ++ search "map" + ," " ++ search "(a -> b) -> [a] -> [b]" + ," " ++ search "Ord a => [a] -> [a]" + ," " ++ search "Data.Map.insert" + ,"
Enter your own search at the top of the page." + ,"

" + ,"

" + ," The Hoogle manual contains more details," + ," including further details on search queries, how to install Hoogle as a command line application" + ," and how to integrate Hoogle with Firefox/Emacs/Vim etc." + ,"

" + ,"

" + ," I am very interested in any feedback you may have. Please " + ," email me, or add an entry to my" + ," bug tracker." + ,"

" + ] + where + search x = "" +& x ++ "
" diff --git a/src/Web/Text.hs b/src/Web/Text.hs new file mode 100644 --- /dev/null +++ b/src/Web/Text.hs @@ -0,0 +1,74 @@ + +module Web.Text where + +import General.Code +import Data.TagStr +import Numeric + + +-- | Only append strings if neither one is empty +(+?) :: String -> String -> String +a +? b = if null a || null b then [] else a ++ b + +-- | Escape the second argument as HTML before appending +(+&) :: String -> String -> String +a +& b = a ++ escapeHTML b + +-- | Escape the second argument as a CGI query string before appending +(+%) :: String -> String -> String +a +% b = a ++ escapeCGI b + + +-- TODO: Should be somewhere else +escapeHTML = concatMap f + where + f '\"' = """ + f '<' = "<" + f '>' = ">" + f '&' = "&" + f '\n' = "
" + f x = [x] + +escapeCGI = concatMap f + where + f x | isAlphaNum x || x `elem` "-" = [x] + | x == ' ' = "+" + | otherwise = '%' : ['0'|length s == 1] ++ s + where s = showHex (ord x) "" + + +showTagHTML = showTagHTMLWith (const Nothing) + + +showTagHTMLWith :: (TagStr -> Maybe String) -> TagStr -> String +showTagHTMLWith f x = g x + where + g x | isJust (f x) = fromJust $ f x + g (Str x) = escapeHTML x + g (Tags xs) = concatMap g xs + g (TagBold x) = "" ++ showTagHTML x ++ "" + g (TagUnderline x) = "" ++ showTagHTML x ++ "" + g (TagHyperlink "" x) = g (TagHyperlink url x) + where str = showTagText x + url = if "http:" `isPrefixOf` str then str else "?hoogle=" +% str + g (TagHyperlink url x) = "" ++ showTagHTML x ++ "" + g (TagColor i x) = "" ++ showTagHTML x ++ "" + + +-- TODO: Should be in Data.TagStr? + +-- TODO: Should only break on spaces +trimTags :: Int -> TagStr -> TagStr +trimTags n (Tags xs) = Tags $ f n xs + where + f n [] = [] + f n (x:xs) | m < n = x : f (n-m) xs + | otherwise = [trimTags n x, Str "..."] + where m = length (showTagText x) +trimTags n x | length (showTagText x) > n = Tags [] + | otherwise = x + + +onStr :: (String -> String) -> TagStr -> TagStr +onStr f (Str x) = Str $ f x +onStr f x = x