diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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 Lesser 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., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 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 Lesser General +Public License instead of this License. diff --git a/Readme b/Readme new file mode 100644 --- /dev/null +++ b/Readme @@ -0,0 +1,39 @@ +Leksah, an Integrated Development Environment for Haskell +========================================================= + +This is Leksah, a hopefully practical tool to support the Haskell development process. + +Leksah uses GTK+ as GUI Toolkit with the gtk2hs binding. It is plattform independend +and should run on any plattform where GTK+, gtk2hs and ghc can be installed. +It is currently been tested on Windows and Linux. It uses the Cabal package management +and build system for Package Management. +It currently only supports the Glasgow Haskell Compiler (ghc). + +Documentation can be found in the doc/ subdirectory. + +System Requirements +=================== + +Leksah currently requires: + GHC version 6.8.x + gtk >=0.9.12, glib >=0.9.12, sourceview >=0.9.12 + which are part of gtk2hs and require GTk+ to be installed + binary >= 0.4.1 + +Leksah works better if you install GHC and additional packages with sources + +Personal words +============== +The development of an IDE is a big issue, so Leksah is intended to become a +community project and everyone is invited to contribute. + +If you are a user or just test Leksah, I would appreciate to here from you. + +Please send questions and suggestions to me: +Jutaro + + + + + + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/data/Current.session b/data/Current.session new file mode 100644 --- /dev/null +++ b/data/Current.session @@ -0,0 +1,6 @@ +Layout: VerticalP (TerminalP (Just TopP) 0) (HorizontalP (HorizontalP (TerminalP (Just TopP) 1) (TerminalP (Just BottomP) 0) 124) (TerminalP (Just BottomP) 0) 587) 769 +Population: [(Just (FindSt FindState),[RightP,TopP,TopP]),(Just (LogSt LogState),[RightP,BottomP]),(Just (ModulesSt (ModulesState 348 (Package,True) (Nothing,Nothing))),[RightP,TopP,BottomP]),(Just (ToolbarSt ToolbarState),[RightP,TopP,TopP])] +Window size: (1400,1001) +Active package: + Nothing +Active pane: Nothing diff --git a/data/Default.candy b/data/Default.candy new file mode 100644 --- /dev/null +++ b/data/Default.candy @@ -0,0 +1,30 @@ +-- Candy file + +"->" 0x2192 Trimming --RIGHTWARDS ARROW +"<-" 0x2190 Trimming --LEFTWARDS ARROW +"=>" 0x21d2 --RIGHTWARDS DOUBLE ARROW +">=" 0x2265 --GREATER-THAN OR EQUAL TO +"<=" 0x2264 --LESS-THAN OR EQUAL TO +"/=" 0x2260 --NOT EQUAL TO +"&&" 0x2227 --LOGICAL AND +"||" 0x2228 --LOGICAL OR +"++" 0x2295 --CIRCLED PLUS +"::" 0x2237 --PROPORTION +".." 0x2025 --TWO DOT LEADER +"^" 0x2191 --UPWARDS ARROW +"==" 0x2261 Trimming --IDENTICAL TO +--"." 0x2218 --RING OPERATOR +"\" 0x03bb --GREEK SMALL LETTER LAMBDA +--"=<<" 0x291e -- +">>=" 0x21a0 + +"forall" 0x2200 --FOR ALL +"exist" 0x2203 --THERE EXISTS +"not" 0x00ac --NOT SIGN +"alpha" 0x03b1 +"beta" 0x03b2 +"gamma" 0x03b3 +"delta" 0x03b4 +"epsilon" 0x03b5 + + diff --git a/data/Default.keymap b/data/Default.keymap new file mode 100644 --- /dev/null +++ b/data/Default.keymap @@ -0,0 +1,77 @@ +--Default Keymap file for Genuine Haskell Face +--Allowed Modifiers are +-- is the Windows key on PC keyboards +-- is often labelled Alt Gr. + + +--File +n -> FileNew "Opens a new empty buffer" + +o -> FileOpen "Opens an existing file" +--x/f -> FileOpen "Opens an existing file" + +s -> FileSave "Saves the current buffer" +--x/s -> FileSave "Saves the current buffer" + +s -> FileSaveAs "Saves the current buffer as a new file" +--x/w -> FileSaveAs "Saves the current buffer as a new file" + +w -> FileClose "Closes the current buffer" +--x/k -> FileClose "Closes the current buffer" + +F4 -> Quit "Quits this program" +--x/c -> Quit "Quits this program" + +--Edit +z -> EditUndo "Undos the last user action" +--x/u -> EditUndo "Undos the last user action" + +y -> EditRedo "Redos the last user action" +--x/r -> EditRedo "Redos the last user action" + +--Just "X" -> EditCut +--Just "C" -> EditCopy +--Just "V" -> EditPaste + -> EditDelete +a -> EditSelectAll "Select the whole text in the current buffer" + +F3 -> EditFind "Quits this program" +f -> EditFindNext "Search for a text string" + +f -> EditFindPrevious + "Find the previous occurence of the text string" +r -> EditReplace + +l -> EditGotoLine "Go to line with a known index" + +Right -> EditComment "Add a line style comment to the selected lies" +Left -> EditUncomment "Remove a line style comment" +Right -> EditShiftRight "Shift right" +Left -> EditShiftLeft "Shift Left" + +--View +Left -> ViewMoveLeft "Move the current pane left" +Right -> ViewMoveRight "Move the current pane right" +Up -> ViewMoveUp "Move the current pane up" +Down -> ViewMoveDown "Move the current pane down" + +2 -> ViewSplitHorizontal + "Split the current pane in horizontal direction" +3 -> ViewSplitVertical + "Split the current pane in vertical direction" +1 -> ViewCollapse "Collapse the panes around the currentla selected pane into one" + + -> ViewTabsLeft "Shows the tabs of the current notebook on the left" + -> ViewTabsRight "Shows the tabs of the current notebook on the right" + -> ViewTabsUp "Shows the tabs of the current notebook on the top" + -> ViewTabsDown "Shows the tabs of the current notebook on the bottom" + -> ViewSwitchTabs "Switches if tabs for the current notebook are visible" + -> HelpDebug + -> HelpAbout + +b -> BuildPackage + +r -> RunPackage + +j -> NextError +j -> PreviousError diff --git a/data/Default.menu b/data/Default.menu new file mode 100644 --- /dev/null +++ b/data/Default.menu @@ -0,0 +1,123 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/data/Default.prefs b/data/Default.prefs new file mode 100644 --- /dev/null +++ b/data/Default.prefs @@ -0,0 +1,26 @@ + +Show line numbers: + True + --(True/False) +TextView Font: "" +Right margin: 96 + --Size or 0 for no right margin +Tab width: 4 +Use standard line ends even on windows: + True +Source candy: Default + --Empty for do not use or the name of a candy file in a config dir +Name of the keymap: + Default + --The name of a keymap file in a config dir +LogView Font: "" +Window default size: + (800,800) + --Default size of the main leksah window specified as pair (int,int) +Browser: "firefox" +Standard source editor path: + LeftTop +Paths under which haskell sources for packages may be found: + [] +Packages which are excluded from the modules pane: + [Dependency "ghc" AnyVersion] diff --git a/data/Emacs.keymap b/data/Emacs.keymap new file mode 100644 --- /dev/null +++ b/data/Emacs.keymap @@ -0,0 +1,66 @@ +--Default Keymap file for Genuine Haskell Face +--Allowed Modifiers are +--Apple is the Windows key on PC keyboards +--Compose is often labelled Alt Gr. + + +--File +n -> FileNew "Opens a new empty buffer" +x/f -> FileOpen "Opens an existing file" +x/s -> FileSave "Saves the current buffer" +x/w -> FileSaveAs "Saves the current buffer as a new file" +x/k -> FileClose "Closes the current buffer" +x/c -> Quit "Quits kthis program" + + +--Edit +x/u -> EditUndo "Undos the last user action" +--_ -> EditUndo "Undos the last user action" +x/r -> EditRedo "Redos the last user action" +w -> EditCut +w -> EditCopy +y -> EditPaste + -> EditDelete +a -> EditSelectAll "Select the whole text in the current buffer" + +s -> EditFind "Search for a text string" +F3 -> EditFindNext "Find the next occurence of the text string" +--k -> EditFind "Search for a text string" + +r -> EditFindPrevious + "Find the previous occurence of the text string" +r -> EditReplace + +L -> EditGotoLine "Go to line with a known index" + +7 -> EditComment "Add a line style comment to the selected lies" +7 -> EditUncomment "Remove a line style comment" +Right -> EditShiftRight "Shift right" +Left -> EditShiftLeft "Shift Left" + +--View +Left -> ViewMoveLeft "Move the current pane left" +Right -> ViewMoveRight "Move the current pane right" +Up -> ViewMoveUp "Move the current pane up" +Down -> ViewMoveDown "Move the current pane down" + +2 -> ViewSplitHorizontal + "Split the current pane in horizontal direction" +3 -> ViewSplitVertical + "Split the current pane in vertical direction" +1 -> ViewCollapse "Collapse the panes around the currentla selected pane into one" + + -> ViewTabsLeft "Shows the tabs of the current notebook on the left" + -> ViewTabsRight "Shows the tabs of the current notebook on the right" + -> ViewTabsUp "Shows the tabs of the current notebook on the top" + -> ViewTabsDown "Shows the tabs of the current notebook on the bottom" + -> ViewSwitchTabs "Switches if tabs for the current notebook are visible" + -> HelpDebug + -> HelpAbout + +b -> BuildPackage + +r -> RunPackage + +j -> NextError +j -> PreviousError diff --git a/data/ide_class.png b/data/ide_class.png new file mode 100644 Binary files /dev/null and b/data/ide_class.png differ diff --git a/data/ide_configure.png b/data/ide_configure.png new file mode 100644 Binary files /dev/null and b/data/ide_configure.png differ diff --git a/data/ide_data.png b/data/ide_data.png new file mode 100644 Binary files /dev/null and b/data/ide_data.png differ diff --git a/data/ide_error_next.png b/data/ide_error_next.png new file mode 100644 Binary files /dev/null and b/data/ide_error_next.png differ diff --git a/data/ide_error_prev.png b/data/ide_error_prev.png new file mode 100644 Binary files /dev/null and b/data/ide_error_prev.png differ diff --git a/data/ide_field.png b/data/ide_field.png new file mode 100644 Binary files /dev/null and b/data/ide_field.png differ diff --git a/data/ide_function.png b/data/ide_function.png new file mode 100644 Binary files /dev/null and b/data/ide_function.png differ diff --git a/data/ide_instance.png b/data/ide_instance.png new file mode 100644 Binary files /dev/null and b/data/ide_instance.png differ diff --git a/data/ide_konstructor.png b/data/ide_konstructor.png new file mode 100644 Binary files /dev/null and b/data/ide_konstructor.png differ diff --git a/data/ide_make.png b/data/ide_make.png new file mode 100644 Binary files /dev/null and b/data/ide_make.png differ diff --git a/data/ide_method.png b/data/ide_method.png new file mode 100644 Binary files /dev/null and b/data/ide_method.png differ diff --git a/data/ide_newtype.png b/data/ide_newtype.png new file mode 100644 Binary files /dev/null and b/data/ide_newtype.png differ diff --git a/data/ide_no_source.png b/data/ide_no_source.png new file mode 100644 Binary files /dev/null and b/data/ide_no_source.png differ diff --git a/data/ide_other.png b/data/ide_other.png new file mode 100644 Binary files /dev/null and b/data/ide_other.png differ diff --git a/data/ide_rule.png b/data/ide_rule.png new file mode 100644 Binary files /dev/null and b/data/ide_rule.png differ diff --git a/data/ide_run.png b/data/ide_run.png new file mode 100644 Binary files /dev/null and b/data/ide_run.png differ diff --git a/data/ide_slot.png b/data/ide_slot.png new file mode 100644 Binary files /dev/null and b/data/ide_slot.png differ diff --git a/data/ide_source.png b/data/ide_source.png new file mode 100644 Binary files /dev/null and b/data/ide_source.png differ diff --git a/data/ide_type.png b/data/ide_type.png new file mode 100644 Binary files /dev/null and b/data/ide_type.png differ diff --git a/data/leksah.png b/data/leksah.png new file mode 100644 Binary files /dev/null and b/data/leksah.png differ diff --git a/doc/Todo.txt b/doc/Todo.txt new file mode 100644 --- /dev/null +++ b/doc/Todo.txt @@ -0,0 +1,52 @@ +Version 0.1 + +Development + +ok - 1 page Documentation +ok - Add next and previous error (and open package) to toolbar +start - Populate Keystrokes +ok - First start feature + +Bugs + - Dynamic exceptions are not caught + - Double log error + - Slow refresh in Modules pane on 6.8.2 + - Candy bug (e.g. exists) + - Activate Pane switching + - GTK Warnings + - Revert on close (2 times even) + - r does not work for PackageRun + - No horizontal centering for errors in source editor + - (Windows only) Gtk runs out of memory and does not displayx correctly ??? + _win32_scaled_font_set_world_transform: Für diesen Befehl ist nicht genügend Speicher verfügbar. + Doesn't happen with Raleigh Theme in Gtk2Hs\etc\gtk-2.0 + - Changed red color not preserved when moving panes + - Collector: No reexported declarations. + - Collector: Getting Instances types right + - empty lines in shift left/right + +ok - Sort field in Info Pane doesn't work + - Sort order of interfaces in module pane? + = Reverse order source collector bug + +Version 0.x + + - Search in interface tree + - Working Cabal Editor with Configurations (etc..) "Change" + - Completion + - Search + - Class Hierarchy pane + - Import helper + - Editor; Highliting according to file type + - Editor Templates for new files + - Properties of single editor (no highlight, no candy,...) + - Haddock (deferr to Haddock 2.0) + - Generic record editor + - Using find in sources without location + - Build only one time - Cancel build + - Source collector only one time - Make it run in background + - Preferences embedden + - Uses Pane + + + diff --git a/doc/leksah_manual.pdf b/doc/leksah_manual.pdf new file mode 100644 Binary files /dev/null and b/doc/leksah_manual.pdf differ diff --git a/leksah.cabal b/leksah.cabal new file mode 100644 --- /dev/null +++ b/leksah.cabal @@ -0,0 +1,72 @@ +name: leksah +version: 0.1 +cabal-version: >= 1.2 +build-type: Custom +license: GPL +license-file: LICENSE +copyright: 2007 Juergen Nicklisch-Franken +maintainer: Juergen Nicklisch-Franken +stability: provisional +homepage: +package-url: http://code.haskell.org/leksah +synopsis: Genuine Haskell Face +description: An Integrated Development Environment for Haskell written in Haskell. +category: Development +author: Jutaro (Juergen Nicklisch-Franken) +data-files: data/Current.session data/Default.candy + data/Default.keymap data/Default.prefs + data/Emacs.keymap data/Default.menu + data/ide_class.png data/ide_configure.png + data/ide_data.png data/ide_error_next.png + data/ide_error_prev.png data/ide_field.png + data/ide_function.png data/ide_instance.png + data/ide_konstructor.png data/ide_make.png + data/ide_method.png data/ide_newtype.png + data/ide_no_source.png + data/ide_other.png data/ide_rule.png + data/ide_run.png data/ide_slot.png + data/ide_source.png data/ide_type.png + data/leksah.png doc/leksah_manual.pdf + doc/Todo.txt Readme +extra-source-files: Setup.lhs +extra-tmp-files: +executable leksah + build-depends: base >=2.1, filepath >=1.0, Cabal >=1.1.6.2, + parsec >=2.0, mtl >=1.0.1, process >=1.0, old-time >=1.0, + containers >=0.1, pretty >=1.0, directory >=1.0, gtk >=0.9.12, + glib >=0.9.12, sourceview >=0.9.12, ghc >= 6.8, binary >= 0.4.1, + bytestring >= 0.9.0.1 + main-is: Main.hs + buildable: True + build-tools: + cpp-options: + cc-options: + ld-options: + pkgconfig-depends: + frameworks: + c-sources: + extensions: + extra-libraries: + extra-lib-dirs: + includes: + install-includes: + include-dirs: + hs-source-dirs: src + other-modules: IDE.Utils.Default + IDE.BuildInfoEditor IDE.CallersPane + IDE.DescriptionPP IDE.Utils.File IDE.FindPane IDE.Leksah IDE.Metainfo.Info + IDE.InfoPane IDE.Metainfo.InterfaceCollector IDE.Keymap + IDE.Log IDE.Menu IDE.ModulesPane IDE.Package IDE.PackageEditor + IDE.PackageFlags IDE.Preferences IDE.PrinterParser + IDE.ReplacePane IDE.RecoverPanes IDE.SaveSession IDE.SourceCandy + IDE.Metainfo.SourceCollector IDE.SourceEditor IDE.SpecialEditors + IDE.ToolbarPane IDE.Framework.ViewFrame IDE.Core.Exception IDE.Core.Panes + IDE.Core.State IDE.Core.Types IDE.Utils.DeepSeq + IDE.Framework.CompositeEditors IDE.Framework.EditorBasics IDE.Framework.MakeEditor + IDE.Framework.Parameters IDE.Framework.SimpleEditors + ghc-prof-options: -prof -auto-all + ghc-shared-options: + ghc-options: -cpp -D__GHC__=680 -D_Newgtk -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns -O2 + hugs-options: + nhc98-options: + jhc-options: diff --git a/src/IDE/BuildInfoEditor.hs b/src/IDE/BuildInfoEditor.hs new file mode 100644 --- /dev/null +++ b/src/IDE/BuildInfoEditor.hs @@ -0,0 +1,315 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +-- +-- | Module for editing of cabal build infos +-- + +module IDE.BuildInfoEditor ( + editBuildInfo -- Maybe FilePath -> [String] -> BuildInfo -> String -> IO (Maybe BuildInfo) +, BuildEditorFactory(..) +, BuildEditorFactoryI(..) +) where + +import Graphics.UI.Gtk +import qualified Graphics.UI.Gtk.ModelView as New(cellText) +import Control.Monad.Reader +import Distribution.PackageDescription +import Data.IORef +import Data.List + +import IDE.Core.State +import IDE.SpecialEditors +import IDE.Framework.ViewFrame +import IDE.Framework.EditorBasics +import IDE.Framework.MakeEditor +import IDE.Framework.SimpleEditors +import IDE.Framework.CompositeEditors +import IDE.Framework.Parameters + +class IDEEditor alpha => BuildEditorFactory alpha where + buildInfoEditor :: alpha -> Maybe FilePath -> [String] -> Editor BuildInfo + libraryEditor :: alpha -> Maybe FilePath -> [String] -> Editor Library + executableEditor :: alpha -> Maybe FilePath -> [String] -> Editor Executable + executablesEditor :: alpha -> Maybe FilePath -> [String] -> Editor [Executable] + +data BuildEditorFactoryI = BuildEditorFactoryI + deriving (Eq,Ord,Show) + +instance IDEObject BuildEditorFactoryI +instance IDEEditor BuildEditorFactoryI +instance BuildEditorFactory BuildEditorFactoryI where + buildInfoEditor factory mbFp list = buildInfoEditor' mbFp list + libraryEditor factory mbFp list = libraryEditor' mbFp list + executableEditor factory mbFp list = executableEditor' mbFp list + executablesEditor factory mbFp list = executablesEditor' mbFp list + +-- ------------------------------------------------------------ +-- * Build Infos +-- ------------------------------------------------------------ + +buildInfoEditor' :: Maybe FilePath -> [String] -> Editor BuildInfo +buildInfoEditor' fp modules p = do + (wid,inj,ext,notif) <- otherEditor (editBuildInfo fp modules) p + box <- vBoxNew False 1 + textView <- textViewNew + widgetSetSizeRequest textView (-1) 300 + containerAdd box wid + containerAdd box textView + buffer <- textViewGetBuffer textView + let binj bi = do + inj bi + textBufferSetText buffer $showHookedBuildInfo (Just bi,[]) + notif FocusIn $Left (changedHandler buffer ext) + return (castToWidget box,binj,ext,notif) + where + changedHandler buffer ext _ = do + mbv <- ext + case mbv of + Just v -> textBufferSetText buffer $showHookedBuildInfo (Just v,[]) + Nothing -> return () + return True + +libraryEditor' :: Maybe FilePath -> [String] -> Editor Library +libraryEditor' fp modules para = do + (wid,inj,ext,notif) <- + pairEditor + (modulesEditor modules, paraName <<<- ParaName "Exposed Modules" $para) + (buildInfoEditor' fp modules, paraName <<<- ParaName "Build Info" $ para) + (paraDirection <<<- ParaDirection Vertical $ emptyParams) + let pinj (Library em bi) = inj (em,bi) + let pext = do + mbp <- ext + case mbp of + Nothing -> return Nothing + Just (em,bi) -> return (Just $Library em bi) + return (wid,pinj,pext,notif) + +modulesEditor :: [String] -> Editor [String] +modulesEditor modules = staticMultiselectionEditor modules + +moduleEditor :: [String] -> Editor String +moduleEditor modules = staticSelectionEditor modules + + +executableEditor' :: Maybe FilePath -> [String] -> Editor Executable +executableEditor' fp modules para = do + (wid,inj,ext,notif) <- pairEditor + (pairEditor + (stringEditor, paraName <<<- ParaName "Executable Name" $ emptyParams) + (fileEditor fp FileChooserActionOpen "Select File", + paraName <<<- ParaName "Main Module" $ emptyParams), + (paraDirection <<<- ParaDirection Vertical $ emptyParams)) + (buildInfoEditor' fp modules, paraName <<<- ParaName "Build Info" $ emptyParams) + (paraDirection <<<- ParaDirection Vertical $ para) + let pinj (Executable s f bi) = inj ((s,f),bi) + let pext = do + mbp <- ext + case mbp of + Nothing -> return Nothing + Just ((s,f),bi) -> return (Just $Executable s f bi) + return (wid,pinj,pext,notif) + +executablesEditor' :: Maybe FilePath -> [String] -> Editor [Executable] +executablesEditor' fp modules p = + multisetEditor + (ColumnDescr False [("Executable Name",\(Executable exeName _ _) -> [New.cellText := exeName]) + ,("Module Path",\(Executable _ mp _) -> [New.cellText := mp])]) + (executableEditor' fp modules ,emptyParams) + (paraShadow <<<- ParaShadow ShadowIn $ p) + +buildInfoD :: Maybe FilePath -> [String] -> [(String,[FieldDescription BuildInfo])] +buildInfoD fp modules = [ + ("Description", [ + mkField + (paraName <<<- ParaName "Component is buildable here" $ emptyParams) + buildable + (\ a b -> b{buildable = a}) + boolEditor + , mkField + (paraName <<<- ParaName "Non-exposed or non-main modules" + $ paraSynopsis <<<- ParaSynopsis ("A list of modules used by the component but " + ++ "not exposed to users.") + $ paraShadow <<<- ParaShadow ShadowIn + $ paraDirection <<<- ParaDirection Vertical + $ emptyParams) + otherModules + (\ a b -> b{otherModules = a}) + (modulesEditor modules) + , mkField + (paraName <<<- ParaName + "Where to look for the haskell module hierarchy" + $ paraSynopsis <<<- ParaSynopsis + "Root directories for the module hierarchy." + $ paraShadow <<<- ParaShadow ShadowIn + $ paraDirection <<<- ParaDirection Vertical + $ emptyParams) + hsSourceDirs + (\ a b -> b{hsSourceDirs = a}) + (filesEditor fp FileChooserActionSelectFolder "Select folder") + ]), + ("Extensions",[ + mkField + (paraName <<<- ParaName "Extensions" + $ paraSynopsis <<<- ParaSynopsis + "A list of Haskell extensions used by every module." + $ emptyParams) + extensions + (\ a b -> b{extensions = a}) + extensionsEditor + ]), + ("Options",[ + mkField + (paraName <<<- ParaName "Options for haskell compilers" + $ paraDirection <<<- ParaDirection Vertical + $ emptyParams) + options + (\ a b -> b{options = a}) + (multisetEditor + (ColumnDescr True [("Compiler Flavor",\(cv,_) -> [New.cellText := show cv]) + ,("Options",\(_,op) -> [New.cellText := show op])]) + ((pairEditor + (compilerFlavorEditor,emptyParams) + (stringsEditor,emptyParams)), + (paraDirection <<<- ParaDirection Vertical + $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams))) + , mkField + (paraName <<<- ParaName "Additional options for GHC when built with profiling" + $ paraDirection <<<- ParaDirection Vertical + $ emptyParams) + ghcProfOptions + (\ a b -> b{ghcProfOptions = a}) + stringsEditor + , mkField + (paraName <<<- ParaName "Options for C compiler" + $ paraDirection <<<- ParaDirection Vertical + $ emptyParams) + ccOptions + (\ a b -> b{ccOptions = a}) + stringsEditor + , mkField + (paraName <<<- ParaName "Options for linker" + $ paraDirection <<<- ParaDirection Vertical + $ emptyParams) + ldOptions + (\ a b -> b{ldOptions = a}) + stringsEditor + ]), + ("C",[ + mkField + (paraName <<<- ParaName "A list of header files already installed on the system" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + includes + (\ a b -> b{includes = a}) + stringsEditor + , mkField + (paraName <<<- ParaName "A list of header files from this package" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + installIncludes + (\ a b -> b{installIncludes = a}) + (filesEditor fp FileChooserActionOpen "Select File") + , mkField + (paraName <<<- ParaName "A list of directories to search for header files" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + includeDirs + (\ a b -> b{includeDirs = a}) + (filesEditor fp FileChooserActionSelectFolder "Select Folder") + , mkField + (paraName <<<- ParaName + "A list of C source files to be compiled,linked with the Haskell files." + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + cSources + (\ a b -> b{cSources = a}) + (filesEditor fp FileChooserActionOpen "Select file") + , mkField + (paraName <<<- ParaName "A list of extra libraries to link with" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + extraLibs + (\ a b -> b{extraLibs = a}) + stringsEditor + , mkField + (paraName <<<- ParaName "A list of directories to search for libraries." + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + extraLibDirs + (\ a b -> b{extraLibDirs = a}) + (filesEditor fp FileChooserActionSelectFolder "Select Folder") + ]), + ("Mac OS X",[ + mkField + (paraName <<<- ParaName "Support frameworks for Mac OS X" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + cSources + (\ a b -> b{cSources = a}) + stringsEditor + ])] + + +editBuildInfo :: Maybe FilePath -> [String] -> BuildInfo -> String -> IO (Maybe BuildInfo) +editBuildInfo fp modules buildInfo contextStr = do + res <- editBuildInfo' buildInfo contextStr (buildInfoD fp modules) + return res + +editBuildInfo' :: BuildInfo -> String -> [(String,[FieldDescription BuildInfo])] -> IO (Maybe BuildInfo) +editBuildInfo' buildInfo contextStr buildInfoD = do + resRef <- newIORef Nothing + dialog <- windowNew + windowSetModal dialog True + vb <- vBoxNew False 7 + bb <- hButtonBoxNew + ok <- buttonNewFromStock "gtk-ok" + cancel <- buttonNewFromStock "gtk-cancel" + boxPackStart bb ok PackNatural 0 + boxPackStart bb cancel PackNatural 0 + nb <- newNotebook + notebookSetTabPos nb PosTop + res <- mapM + (\ (tabLabel, partBuildInfoD) -> do + resList <- mapM (\ (FD _ editorF) -> editorF buildInfo) partBuildInfoD + let (widgetsP, setInjsP, getExtsP,notifiersP) = unzip4 resList + nbbox <- vBoxNew False 0 + mapM_ (\ w -> boxPackStart nbbox w PackNatural 0) widgetsP + sw <- scrolledWindowNew Nothing Nothing + scrolledWindowAddWithViewport sw nbbox + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + notebookAppendPage nb sw tabLabel + return (widgetsP, setInjsP, getExtsP, notifiersP)) + buildInfoD + let (widgets, setInjs, getExts, notifiers) = + foldl (\ (w,i,e,n) (w2,i2,e2,n2) -> (w ++ w2, i ++ i2, e ++ e2, n ++ n2)) ([],[],[],[]) res + let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of + Just s -> s + Nothing -> "Unnamed") + $concatMap snd buildInfoD + ok `onClicked` (do + mbNewBuildInfo <- extractAndValidate buildInfo getExts fieldNames + case mbNewBuildInfo of + Nothing -> do + sysMessage Normal "Cant't validate build info" + return () + Just newBuildInfo -> do + writeIORef resRef (Just newBuildInfo) + widgetDestroy dialog + mainQuit + return ()) + cancel `onClicked` (do + widgetDestroy dialog + mainQuit + return ()) + dialog `onDelete` (\e -> do + widgetDestroy dialog + mainQuit + return True) + boxPackStart vb nb PackGrow 7 + boxPackEnd vb bb PackNatural 7 + containerAdd dialog vb + widgetSetSizeRequest dialog 500 700 + widgetShowAll dialog + mainGUI + res <- readIORef resRef + return (res) + + + + + + + + diff --git a/src/IDE/CallersPane.hs b/src/IDE/CallersPane.hs new file mode 100644 --- /dev/null +++ b/src/IDE/CallersPane.hs @@ -0,0 +1,219 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.CallersPane +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | The pane of ide where modules are presented in tree form with their +-- packages and exports +-- +------------------------------------------------------------------------------- + +module IDE.CallersPane ( + calledBy +) where + +import Graphics.UI.Gtk hiding (get) +import Graphics.UI.Gtk.ModelView as New +import Data.Maybe +import Control.Monad.Reader +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.List +import Distribution.Package + +import IDE.Core.State +import IDE.Framework.ViewFrame + +instance IDEObject IDECallers +instance Pane IDECallers + where + primPaneName _ = "Callers" + getAddedIndex _ = 0 + getTopWidget = castToWidget . scrolledView + paneId b = "*Callers" + makeActive p = do + activatePane p (BufConnections[][] []) + close pane = do + (panePath,_) <- guiPropertiesFromName (paneName pane) + nb <- getNotebook panePath + mbI <- lift $notebookPageNum nb (getTopWidget pane) + case mbI of + Nothing -> lift $ do + sysMessage Normal "notebook page not found: unexpected" + return () + Just i -> do + deactivatePaneIfActive pane + lift $notebookRemovePage nb i + removePaneAdmin pane + +-- | We don't recover this pane +instance RecoverablePane IDECallers CallersState where + saveState p = return Nothing + recoverState pp _ = return () + + +-- | Open a pane with the callers of this identifier +calledBy :: IdentifierDescr + -> IDEAction +calledBy idDescr = do + mbCurrentInfo <- readIDE currentInfo + case mbCurrentInfo of + Nothing -> return () + Just currentInfo' -> + let symModPair = (identifierID idDescr, modu $ moduleIdID idDescr) + modulesList1 = modulesForCallerFromPackages + (Map.elems $ fst $ fst currentInfo') symModPair + modulesList2 = modulesForCallerFromPackages + (Map.elems $ fst $ snd currentInfo') symModPair + modulesList = nub $ modulesList1 ++ modulesList2 + finalList = zip modulesList (repeat (identifierID idDescr)) + in do callers <- getCallers + lift $ do + New.listStoreClear (callersStore callers) + mapM_ (New.listStoreAppend (callersStore callers)) finalList + bringPaneToFront callers + +modulesForCallerFromPackages :: [PackageDescr] -> (Symbol,ModuleIdentifier) -> [ModuleDescr] +modulesForCallerFromPackages [] _ = [] +modulesForCallerFromPackages (p :rest) (sym,mod) = + (filter (\ md -> case mod `Map.lookup` (usagesMD md) of + Nothing -> False + Just syms -> sym `Set.member` syms) (exposedModulesPD p)) + ++ modulesForCallerFromPackages rest (sym,mod) + +getCallers :: IDEM IDECallers +getCallers = do + mbMod <- getPane CallersCasting + case mbMod of + Nothing -> do + prefs <- readIDE prefs + layout <- readIDE layout + let pp = getStandardPanePath (modulesPanePath prefs) layout + nb <- getNotebook pp + initCallers pp nb + mbMod <- getPane CallersCasting + case mbMod of + Nothing -> throwIDE "Can't init callers" + Just m -> return m + Just m -> return m + +initCallers :: PanePath -> Notebook -> IDEAction +initCallers panePath nb = do + ideR <- ask + panes <- readIDE panes + paneMap <- readIDE paneMap + prefs <- readIDE prefs + currentInfo <- readIDE currentInfo + (buf,cids) <- lift $ do + treeStore <- New.listStoreNew [] + treeView <- New.treeViewNew + New.treeViewSetModel treeView treeStore + + renderer0 <- New.cellRendererPixbufNew + set renderer0 [ cellPixbufStockId := stockYes ] + + renderer <- New.cellRendererTextNew + col <- New.treeViewColumnNew + New.treeViewColumnSetTitle col "Modules" + New.treeViewColumnSetSizing col TreeViewColumnAutosize + New.treeViewColumnSetReorderable col True + New.treeViewAppendColumn treeView col + New.cellLayoutPackStart col renderer0 False + New.cellLayoutPackStart col renderer True + New.cellLayoutSetAttributes col renderer treeStore + $ \row -> [ New.cellText := modu $ moduleIdMD $ fst row] + New.cellLayoutSetAttributes col renderer0 treeStore + $ \row -> [cellPixbufStockId := + if isJust (mbSourcePathMD $ fst row) + then stockJumpTo + else stockYes] + + renderer2 <- New.cellRendererTextNew + col2 <- New.treeViewColumnNew + New.treeViewColumnSetTitle col2 "Packages" + New.treeViewColumnSetSizing col2 TreeViewColumnAutosize + New.treeViewColumnSetReorderable col2 True + New.treeViewAppendColumn treeView col2 + New.cellLayoutPackStart col2 renderer2 True + New.cellLayoutSetAttributes col2 renderer2 treeStore + $ \row -> [ New.cellText := showPackageId $ pack $ moduleIdMD $ fst row] + + New.treeViewSetHeadersVisible treeView True + + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw treeView + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + let modules = IDECallers sw treeView treeStore + notebookInsertOrdered nb sw (paneName modules) + widgetShowAll sw + +-- cid1 <- treeView `afterFocusIn` +-- (\_ -> do runReaderT (makeActive modules) ideR; return True) +-- cid2 <- facetView `afterFocusIn` +-- (\_ -> do runReaderT (makeActive modules) ideR; return True) +-- treeView `onButtonPress` (treeViewPopup ideR treeStore treeView) +-- facetView `onButtonPress` (facetViewPopup ideR facetStore facetView) +-- sel <- New.treeViewGetSelection treeView +-- sel `New.onSelectionChanged` (fillFacets treeView treeStore facetStore) +-- sel2 <- New.treeViewGetSelection facetView +-- sel2 `New.onSelectionChanged` (fillInfo facetView facetStore ideR) + + return (modules,[]) + addPaneAdmin buf (BufConnections [] [] []) panePath + lift $widgetGrabFocus (scrolledView buf) + + +--getSelectionTree :: New.TreeView +-- -> New.ListStore (String, [(ModuleDescr,PackageDescr)]) +-- -> IO (Maybe (String, [(ModuleDescr,PackageDescr)])) +--getSelectionTree treeView listStore = do +-- treeSelection <- New.treeViewGetSelection treeView +-- paths <- New.treeSelectionGetSelectedRows treeSelection +-- case paths of +-- [] -> return Nothing +-- a:r -> do +-- val <- New.listStoreGetValue listStore a +-- return (Just val) + +--treeViewPopup :: IDERef +-- -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) +-- -> New.TreeView +-- -> Event +-- -> IO (Bool) +--treeViewPopup ideR store treeView (Button _ click _ _ _ _ button _ _) = do +-- if button == RightButton +-- then do +-- theMenu <- menuNew +-- item1 <- menuItemNewWithLabel "Edit" +-- item1 `onActivateLeaf` do +-- sel <- getSelectionTree treeView store +-- case sel of +-- Just (_,[(m,_)]) -> case mbSourcePathMD m of +-- Nothing -> return () +-- Just fp -> do +-- runReaderT (selectSourceBuf fp) ideR +-- return () +-- otherwise -> return () +-- menuShellAppend theMenu item1 +-- menuPopup theMenu Nothing +-- widgetShowAll theMenu +-- return True +-- else if button == LeftButton && click == DoubleClick +-- then do sel <- getSelectionTree treeView store +-- case sel of +-- Just (_,[(m,_)]) -> case mbSourcePathMD m of +-- Nothing -> return () +-- Just fp -> do +-- runReaderT (selectSourceBuf fp) ideR +-- return () +-- otherwise -> return () +-- return True +-- else return False +--treeViewPopup _ _ _ _ = throwIDE "treeViewPopup wrong event type" + diff --git a/src/IDE/Core/Exception.hs b/src/IDE/Core/Exception.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Core/Exception.hs @@ -0,0 +1,101 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Core.Exception +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | A Type for IDE exceptions +-- Taken from Haddock example. +-- +------------------------------------------------------------------------------- + +module IDE.Core.Exception ( + IDEException +, throwIDE +, sysMessage +, MessageLevel(..) +, handleTopExceptions +) where + +import Data.Typeable +import Control.Exception +import System.IO +import Prelude hiding(catch) +import System.Exit + +import Panic +import Bag +import ErrUtils +import DynFlags + +data IDEException = IDEException String + deriving Typeable + +instance Show IDEException where + show (IDEException str) = str + +-- dynamic exceptions doesn't work for me, why +--throwIDE str = throwDyn (IDEException str) +throwIDE str = error str + + +sysMessage :: MessageLevel -> String -> IO () +sysMessage ml str = do + putStrLn str + hFlush stdout + +data MessageLevel = Silent | Normal | High + deriving (Eq,Ord,Show) + + +-- --------------------------------------------------------------------- +-- Exception handling +-- + +handleTopExceptions = + handleNormalExceptions . handleIDEExceptions . handleGhcExceptions + +handleNormalExceptions inner = + catch inner (\exception -> do + hFlush stdout + case exception of + AsyncException StackOverflow -> do + sysMessage Normal "stack overflow: use -g +RTS -K to increase it" + exitFailure + ExitException code -> exitWith code + _other -> do + sysMessage Normal ("ide: internal IDE error: " ++ show exception) + exitFailure + ) + + +handleIDEExceptions inner = + catchDyn inner (\(e::IDEException) -> do + sysMessage Normal $ "ide: " ++ (show e) + hFlush stdout + exitFailure + ) + + +handleGhcExceptions inner = + -- throwIDE messages propagated as exceptions + let inner2 = catchDyn inner (\(dyn::GhcException) -> do + hFlush stdout + case dyn of + PhaseFailed _ code -> exitWith code + Interrupted -> exitFailure + _ -> do + print dyn + exitFailure) + in + -- compilation errors: messages with locations attached + catchDyn inner2 (\dyn -> do + sysMessage Normal "ide: Compilation error(s):" + printBagOfErrors defaultDynFlags (unitBag dyn) + exitFailure + ) diff --git a/src/IDE/Core/Panes.hs b/src/IDE/Core/Panes.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Core/Panes.hs @@ -0,0 +1,370 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Core.Panes +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | The core state of ide. This module is imported from every other module, +-- | and all data structures of the state are declared here, to avoid circular +-- | module dependencies. +-- +------------------------------------------------------------------------------- + +module IDE.Core.Panes ( +-- Casting(..) +--, CastingS(..) + +-- * Panes and pane layout + Pane(..) +, CastablePane(..) +, Casting(..) +, IDEPane(..) +, RecoverablePane(..) +, PaneDirection(..) +, PanePath +, PaneLayout(..) +, PaneName +, Connections(..) + +, IDEState(..) +, PaneState(..) +, Recoverable(..) + +-- * The pane types +, IDEBuffer(..) +, BufferState(..) +, IDEInfo(..) +, InfoState(..) +, FacetWrapper(..) +, IDEModules(..) +, ModulesState(..) +, IDECallers(..) +, CallersState(..) +, IDEToolbar(..) +, ToolbarState(..) + +, IDEReplace(..) +, ReplaceState(..) + +, IDELog(..) +, LogState(..) +, LogTag(..) + +, IDEFind(..) +, FindState(..) + + + +) where + +import Graphics.UI.Gtk.SourceView +import Graphics.UI.Gtk hiding (get) +import Graphics.UI.Gtk.ModelView as New +import System.Glib.Signals +import Data.Maybe +import System.Time +import GHC.IOBase hiding (BufferState) + +import IDE.Core.Types +import {-# SOURCE #-} IDE.Core.State +import IDE.Framework.EditorBasics +-- --------------------------------------------------------------------- +-- Panes and pane layout +-- + + +-- +-- | A path to a pane +-- +type PanePath = [PaneDirection] + +-- +-- | The relative direction to a pane from the parent +-- +data PaneDirection = TopP | BottomP | LeftP | RightP + deriving (Eq,Show,Read) + +-- +-- | Description of a window layout +-- +data PaneLayout = HorizontalP PaneLayout PaneLayout Int + | VerticalP PaneLayout PaneLayout Int + | TerminalP (Maybe PaneDirection) Int + deriving (Eq,Show,Read) + +-- +-- | Signal handlers for the different pane types +-- +data Connections = BufConnections + [ConnectId SourceView] + [ConnectId TextBuffer] + [ConnectId TextView] +-- [ConnectId New.TreeView] + +type PaneName = String + +-- +-- | Description of the different pane types +-- + +class IDEObject alpha => Pane alpha where + paneName :: alpha -> PaneName + paneName b = if getAddedIndex b == 0 + then primPaneName b + else primPaneName b ++ "(" ++ show (getAddedIndex b) ++ ")" + primPaneName :: alpha -> String + getAddedIndex :: alpha -> Int + getAddedIndex _ = 0 + getTopWidget :: alpha -> Widget + paneId :: alpha -> String + makeActive :: alpha -> IDEAction + close :: alpha -> IDEAction + + +class (Pane alpha, Recoverable beta) => RecoverablePane alpha beta | beta -> alpha, alpha -> beta where + saveState :: alpha -> IDEM (Maybe IDEState) + recoverState :: PanePath -> beta -> IDEAction + +class CastablePane alpha where + casting :: alpha -> Casting alpha + downCast :: Casting alpha -> IDEPane -> Maybe alpha + isIt :: Casting alpha -> IDEPane -> Bool + isIt t i = isJust (downCast t i) + +data Casting alpha where + LogCasting :: Casting IDELog + InfoCasting :: Casting IDEInfo + BufferCasting :: Casting IDEBuffer + ModulesCasting :: Casting IDEModules + CallersCasting :: Casting IDECallers + ToolbarCasting :: Casting IDEToolbar + FindCasting :: Casting IDEFind + ReplaceCasting :: Casting IDEReplace + +data IDEPane = forall alpha beta . (CastablePane alpha, RecoverablePane alpha beta) => PaneC alpha + +instance IDEObject IDEPane + +instance Pane IDEPane where + paneName (PaneC a) = paneName a + primPaneName (PaneC a) = primPaneName a + getAddedIndex (PaneC a) = getAddedIndex a + getTopWidget (PaneC a) = getTopWidget a + paneId (PaneC a) = paneId a + makeActive (PaneC a) = makeActive a + close (PaneC a) = close a + +class Recoverable alpha where + toPaneState :: alpha -> PaneState + +data IDEState = forall alpha beta . (RecoverablePane alpha beta, Recoverable beta) => StateC beta + +instance Recoverable IDEState where + toPaneState (StateC a) = toPaneState a + +instance RecoverablePane IDEPane IDEState where + saveState (PaneC p) = saveState p + recoverState pp (StateC s) = recoverState pp s + +-- --------------------------------------------------------------------- +-- All pane types must be in here ! +-- + +data PaneState = BufferSt BufferState + | LogSt LogState + | InfoSt InfoState + | ModulesSt ModulesState + | CallersSt CallersState + | ToolbarSt ToolbarState + | FindSt FindState + | ReplaceSt ReplaceState + deriving(Eq,Ord,Read,Show) + +-- --------------------------------------------------------------------- +-- Special Panes - The data structures for the panes +-- + +-- +-- | A text editor pane description +-- +data IDEBuffer = IDEBuffer { + fileName :: Maybe FilePath +, bufferName :: String +, addedIndex :: Int +, sourceView :: SourceView +, scrolledWindow :: ScrolledWindow +, modTime :: Maybe (ClockTime) +} + + +instance CastablePane IDEBuffer where + casting _ = BufferCasting + downCast _ (PaneC a) + = case casting a of + BufferCasting -> Just a + _ -> Nothing + +data BufferState = BufferState FilePath Int + deriving(Eq,Ord,Read,Show) + +instance Recoverable BufferState where + toPaneState a = BufferSt a + + +-- +-- | An info pane description +-- +data IDEInfo = IDEInfo { + sw :: ScrolledWindow +, currentIDs :: IORef [IdentifierDescr] +, currentInd :: IORef Int +, injectors :: [IdentifierDescr -> IO()] +, extractors :: [IdentifierDescr -> Extractor IdentifierDescr] +, nextB :: Button +, prevB :: Button +, numLabel :: Label +} + +instance CastablePane IDEInfo where + casting _ = InfoCasting + downCast _ (PaneC a) = case casting a of + InfoCasting -> Just a + _ -> Nothing + +data InfoState = InfoState [IdentifierDescr] Int + deriving(Eq,Ord,Read,Show) + +instance Recoverable InfoState where + toPaneState a = InfoSt a + + +-- | A modules pane description +-- + +data IDEModules = IDEModules { + outer :: VBox +, paned :: HPaned +, treeView :: New.TreeView +, treeStore :: New.TreeStore (String, [(ModuleDescr,PackageDescr)]) +, facetView :: New.TreeView +, facetStore :: New.TreeStore FacetWrapper +, localScopeB :: RadioButton +, packageScopeB :: RadioButton +, worldScopeB :: RadioButton +, blacklistB :: CheckButton +} + +instance CastablePane IDEModules where + casting _ = ModulesCasting + downCast _ (PaneC a) = case casting a of + ModulesCasting -> Just a + _ -> Nothing + +data FacetWrapper = + Itself IdentifierDescr + | ConstructorW Symbol IdentifierDescr + | FieldW Symbol IdentifierDescr + | MethodW Symbol IdentifierDescr + | OrphanedData IdentifierDescr + +data ModulesState = ModulesState Int (Scope,Bool) + (Maybe String, Maybe String) + deriving(Eq,Ord,Read,Show) + +instance Recoverable ModulesState where + toPaneState a = ModulesSt a + + +-- | A callers pane description +-- + +data IDECallers = IDECallers { + scrolledView :: ScrolledWindow +, treeViewC :: New.TreeView +, callersStore :: New.ListStore (ModuleDescr,Symbol) +} + +instance CastablePane IDECallers where + casting _ = CallersCasting + downCast _ (PaneC a) = case casting a of + CallersCasting -> Just a + _ -> Nothing + +data CallersState = CallersState + deriving(Eq,Ord,Read,Show) + +instance Recoverable CallersState where + toPaneState a = CallersSt a + +-- | A Toolbar pane description +-- +data IDEToolbar = IDEToolbar { + toolbar :: VBox +} + +instance CastablePane IDEToolbar where + casting _ = ToolbarCasting + downCast _ (PaneC a) = case casting a of + ToolbarCasting -> Just a + _ -> Nothing + +data ToolbarState = ToolbarState + deriving(Eq,Ord,Read,Show) + +instance Recoverable ToolbarState where + toPaneState a = ToolbarSt a + +-- | A Control pane for simple text replace +-- + +data IDEReplace = IDEReplace { + replaceBox :: VBox +--, replaceExtractor :: Extractor ReplaceState +} + +data ReplaceState = ReplaceState{ + searchFor :: String +, replaceWith :: String +, matchCase :: Bool +, matchEntire :: Bool +, searchBackwards :: Bool} + deriving(Eq,Ord,Read,Show) + +-- +-- | The Log Viev +-- + +data IDELog = IDELog { + textView :: TextView +, scrolledWindowL :: ScrolledWindow} + +data LogState = LogState + deriving(Eq,Ord,Read,Show) + +data LogTag = LogTag | ErrorTag | FrameTag + + +-- | A Find pane description +-- + +data IDEFind = IDEFind { + findBox :: HBox +, caseSensitive :: ToggleButton +, wrapAround :: ToggleButton +, entireWord :: ToggleButton +, gotoLine :: SpinButton +, findEntry :: Entry +} + +data FindState = FindState + deriving(Eq,Ord,Read,Show) + + + + + diff --git a/src/IDE/Core/State.hs b/src/IDE/Core/State.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Core/State.hs @@ -0,0 +1,231 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Core.State +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | The core state of ide. This module is imported from every other module, +-- | and all data structures of the state are declared here, to avoid circular +-- | module dependencies. +-- +------------------------------------------------------------------------------- + +module IDE.Core.State ( + IDEObject(..) +, IDEEditor +, IDE(..) +, IDERef +, IDEM +, IDEAction +, IDEEvent(..) +, EventSelector(..) + +-- * Convenience methods for accesing the IDE State +, readIDE +, modifyIDE +, modifyIDE_ +, withIDE +, getIDE + +, ideMessage +, logMessage +, forceJust +, module IDE.Core.Types +, module IDE.Core.Panes +, module IDE.Core.Exception + +) where + +import Graphics.UI.Gtk hiding (get) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.IORef +import Control.Monad.Reader +import GHC (Session) +import Data.Unique + +import IDE.Core.Types +import IDE.Core.Panes +import IDE.Core.Exception + +ideMessage :: MessageLevel -> String -> IDEAction +ideMessage level str = do + st <- ask + triggerEvent st (LogMessage (str ++ "\n") LogTag) + lift $ sysMessage level str + +logMessage :: String -> LogTag -> IDEAction +logMessage str tag = do + st <- ask + triggerEvent st (LogMessage (str ++ "\n") tag) + return () + +data IDEEvent = + CurrentInfo + | ActivePack + | SelectInfo String + | SelectIdent IdentifierDescr + | LogMessage String LogTag + | GetToolbar [Widget] + +data EventSelector = + CurrentInfoS + | ActivePackS + | SelectInfoS + | SelectIdentS + | LogMessageS + | GetToolbarS + deriving (Eq,Ord,Show) + +eventAsSelector :: IDEEvent -> EventSelector +eventAsSelector CurrentInfo = CurrentInfoS +eventAsSelector ActivePack = ActivePackS +eventAsSelector (LogMessage _ _) = LogMessageS +eventAsSelector (GetToolbar _) = GetToolbarS +eventAsSelector (SelectInfo _) = SelectInfoS +eventAsSelector (SelectIdent _) = SelectIdentS + +class IDEObject alpha where + + canTriggerEvent :: alpha -> EventSelector -> Bool + canTriggerEvent _ _ = False + + triggerEvent :: alpha -> IDEEvent -> IDEM IDEEvent + triggerEvent o e = + if canTriggerEvent o (eventAsSelector e) + then do + handlerMap <- readIDE handlers + let selector = eventAsSelector e + case selector `Map.lookup` handlerMap of + Nothing -> return e + Just l -> foldM (\e (_,ah) -> ah e) e l + else throwIDE $ "Object can't trigger event " ++ show (eventAsSelector e) + + registerEvent :: alpha -> EventSelector -> Either (IDEEvent -> IDEM IDEEvent) Unique -> IDEM Unique + registerEvent o e (Left handler) = do + handlerMap <- readIDE handlers + unique <- lift $ newUnique + let newHandlers = case e `Map.lookup` handlerMap of + Nothing -> Map.insert e [(unique,handler)] handlerMap + Just l -> Map.insert e ((unique,handler):l) handlerMap + modifyIDE_ (\ide -> return (ide{handlers = newHandlers})) + return unique + registerEvent o e (Right unique) = do + handlerMap <- readIDE handlers + let newHandlers = case e `Map.lookup` handlerMap of + Nothing -> handlerMap + Just l -> let newList = filter (\ (mu,_) -> mu /= unique) l + in Map.insert e newList handlerMap + modifyIDE_ (\ide -> return (ide{handlers = newHandlers})) + return unique + + +class IDEObject o => IDEEditor o + + +-- --------------------------------------------------------------------- +-- IDE State +-- + +-- +-- | The IDE state +-- +data IDE = IDE { + window :: Window -- ^ the gtk window +, uiManager :: UIManager -- ^ the gtk uiManager +, panes :: Map PaneName IDEPane -- ^ a map with all panes (subwindows) +, activePane :: Maybe (PaneName,Connections) +, paneMap :: Map PaneName (PanePath, Connections) + -- ^ a map from the pane name to its gui path and signal connections +, layout :: PaneLayout -- ^ a description of the general gui layout +, specialKeys :: SpecialKeyTable IDERef -- ^ a structure for emacs like keystrokes +, specialKey :: SpecialKeyCons IDERef -- ^ the first of a double keystroke +, candy :: CandyTable -- ^ table for source candy +, prefs :: Prefs -- ^ configuration preferences +, activePack :: Maybe IDEPackage +, errors :: [ErrorSpec] +, currentErr :: Maybe Int +, accessibleInfo :: (Maybe (PackageScope)) -- ^ the world scope +, currentInfo :: (Maybe (PackageScope,PackageScope)) + -- ^ the first is for the current package, + --the second is the scope in the current package +, session :: Session -- ^ a ghc session object, side effects + -- reusing with sessions? +, handlers :: Map EventSelector [(Unique, IDEEvent -> IDEM IDEEvent)] + -- ^ event handling table +} --deriving Show + +instance IDEObject IDERef where + canTriggerEvent o LogMessageS = True + canTriggerEvent o GetToolbarS = True + canTriggerEvent o SelectInfoS = True + canTriggerEvent o SelectIdentS = True + canTriggerEvent o CurrentInfoS = True + canTriggerEvent o ActivePackS = True +-- canTriggerEvent o _ = False + +-- +-- | A mutable reference to the IDE state +-- +type IDERef = IORef IDE + +-- +-- | A reader monad for a mutable reference to the IDE state +-- +type IDEM = ReaderT (IDERef) IO + +-- +-- | A shorthand for a reader monad for a mutable reference to the IDE state +-- which does not return a value +-- +type IDEAction = IDEM () + +-- --------------------------------------------------------------------- +-- Convenience methods for accesing the IDE State +-- + +-- | Read an attribute of the contents +readIDE :: (IDE -> beta) -> IDEM beta +readIDE f = do + e <- ask + lift $ liftM f (readIORef e) + +-- | Modify the contents, using an IO action. +modifyIDE_ :: (IDE -> IO IDE) -> IDEM () +modifyIDE_ f = do + e <- ask + e' <- lift $ (f =<< readIORef e) + lift $ writeIORef e e' + +-- | Variation on modifyIDE_ that lets you return a value +modifyIDE :: (IDE -> IO (IDE,beta)) -> IDEM beta +modifyIDE f = do + e <- ask + (e',result) <- lift (f =<< readIORef e) + lift $ writeIORef e e' + return result + +withIDE :: (IDE -> IO alpha) -> IDEM alpha +withIDE f = do + e <- ask + lift $ f =<< readIORef e + +getIDE :: IDEM(IDE) +getIDE = do + e <- ask + st <- lift $ readIORef e + return st + +-- --------------------------------------------------------------------- +-- Convenience methods for accesing the IDE State +-- +forceJust :: Maybe alpha -> String -> alpha +forceJust mb str = case mb of + Nothing -> throwIDE str + Just it -> it + diff --git a/src/IDE/Core/State.hs-boot b/src/IDE/Core/State.hs-boot new file mode 100644 --- /dev/null +++ b/src/IDE/Core/State.hs-boot @@ -0,0 +1,20 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +module IDE.Core.State ( + IDEObject +, IDERef +, IDEM +, IDEAction +) where + +import Data.IORef +import Control.Monad.Reader + + +class IDEObject o + +data IDE +type IDERef = IORef IDE +type IDEM = ReaderT (IDERef) IO +type IDEAction = IDEM () + + diff --git a/src/IDE/Core/Types.hs b/src/IDE/Core/Types.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Core/Types.hs @@ -0,0 +1,366 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Core.Data +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | The core state of ide. This module is imported from every other module, +-- | and all data structures of the state are declared here, to avoid circular +-- | module dependencies. +-- +------------------------------------------------------------------------------- + +module IDE.Core.Types ( + + IDEPackage(..) +, StandardPath(..) + +, ActionDescr(..) +, ActionString +, KeyString + +, Prefs(..) + +, ErrorSpec(..) + +, PackageDescr(..) +, ModuleDescr(..) +, IdentifierDescr(..) +, Symbol +, ClassId +, DataId +, TypeInfo +, ModuleIdentifier +, IdType(..) +, IdTypeS(..) +, SymbolTable +, PackageScope +, PackModule(..) +, showPackModule +, parsePackModule +, fromPackageIdentifier +, toPackageIdentifier +, idDescriptionsPD +, allFieldsID +, allConstructorsID +, allClassOpsID +, typeInfo +, idType + +, Location(..) +, Scope(..) + +, SearchHint(..) +, CandyTable(..) +, CandyTableForth +, CandyTableBack +, KeymapI(..) +, SpecialKeyTable +, SpecialKeyCons + +) where + +import Control.Monad.Reader +import Graphics.UI.Gtk hiding (get) +import Distribution.Package +import Distribution.Version +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set(Set) +import qualified Data.Set as Set +import Text.ParserCombinators.ReadP +import qualified Data.ByteString.Char8 as BS +import Data.ByteString.Char8 (ByteString) + +import IDE.Utils.Default +import IDE.Core.Exception + + +data StandardPath = LeftTop | LeftBottom | RightTop | RightBottom + deriving(Read,Show,Eq,Enum) + +-- --------------------------------------------------------------------- +-- IDEPackages +-- + +data IDEPackage = IDEPackage { + packageId :: PackageIdentifier +, cabalFile :: FilePath +, depends :: [Dependency] +, configFlags :: [String] +, buildFlags :: [String] +, haddockFlags :: [String] +, exeFlags :: [String] +, installFlags :: [String] +, registerFlags :: [String] +, unregisterFlags :: [String] +, sdistFlags :: [String] +} + deriving (Eq,Show) + +-- --------------------------------------------------------------------- +-- Other data structures which are used in the state +-- + +-- +-- | ActionDescr is a data structure from which GtkActions are build, which are used for +-- menus, toolbars, and accelerator keystrokes +-- +data ActionDescr alpha = AD { + name :: ActionString +, label :: String +, tooltip :: Maybe String +, stockID :: Maybe String +, action :: ReaderT alpha IO () +, accelerator :: [KeyString] +, isToggle :: Bool +} + +type ActionString = String +type KeyString = String + +-- +-- | Preferences is a data structure to hold configuration data +-- +data Prefs = Prefs { + showLineNumbers :: Bool +, rightMargin :: Maybe Int +, tabWidth :: Int +, sourceCandy :: Maybe String +, keymapName :: String +, forceLineEnds :: Bool +, textviewFont :: Maybe String +, logviewFont :: Maybe String +, defaultSize :: (Int,Int) +, browser :: String +, sourcePanePath :: StandardPath +, logPanePath :: StandardPath +, infoPanePath :: StandardPath +, modulesPanePath :: StandardPath +, controlPanePath :: StandardPath +, sourceDirectories :: [FilePath] +, packageBlacklist :: [Dependency] +} deriving(Eq,Show) + +data SearchHint = Forward | Backward | Insert | Delete | Initial + deriving (Eq) + + + +instance Show Modifier + where show Shift = "" + show Control = "" + show Alt = "" + show Apple = "" + show Compose = "" + +-- +-- | Other types +-- +data ErrorSpec = ErrorSpec { + filePath :: FilePath +, line :: Int +, column :: Int +, errDescription :: String +, logLines :: (Int,Int) +, isError :: Bool +} deriving Show + +-- --------------------------------------------------------------------- +-- | Information about the world, extraced from .hi and maybe source files +-- + +type PackageScope = (Map PackageIdentifier PackageDescr,SymbolTable) +type SymbolTable = Map Symbol [IdentifierDescr] + +data PackageDescr = PackageDescr { + packagePD :: PackageIdentifier +, mbSourcePathPD :: (Maybe FilePath) +, exposedModulesPD :: [ModuleDescr] +, buildDependsPD :: [PackageIdentifier] +} deriving Show + +instance Eq PackageDescr where + (==) a b = packagePD a == packagePD b + +instance Ord PackageDescr where + (<=) a b = packagePD a <= packagePD b + + +data ModuleDescr = ModuleDescr { + moduleIdMD :: PackModule +, mbSourcePathMD :: (Maybe FilePath) +, exportedNamesMD :: (Set Symbol) -- unqualified +, usagesMD :: (Map ModuleIdentifier (Set Symbol)) -- imports +, idDescriptionsMD :: [IdentifierDescr] +} deriving Show + +instance Eq ModuleDescr where + (==) a b = moduleIdMD a == moduleIdMD b + +instance Ord ModuleDescr where + (<=) a b = moduleIdMD a <= moduleIdMD b + +data IdentifierDescr = + SimpleDescr { + identifierID :: Symbol + , identifierTypeID :: IdTypeS + , typeInfoID :: TypeInfo + , moduleIdID :: PackModule + , mbLocation :: (Maybe Location) + , mbComment :: (Maybe ByteString)} + | DataDescr { + identifierID :: Symbol + , typeInfoID :: TypeInfo + , moduleIdID :: PackModule + , constructorsID :: [Symbol] + , fieldsID :: [Symbol] + , mbLocation :: (Maybe Location) + , mbComment :: (Maybe ByteString)} + | ClassDescr { + identifierID :: Symbol + , typeInfoID :: TypeInfo + , moduleIdID :: PackModule + , classOpsID :: [Symbol] + , mbLocation :: (Maybe Location) + , mbComment :: (Maybe ByteString)} + | InstanceDescr { + identifierID :: Symbol --the class + , binds :: [Symbol] + , moduleIdID :: PackModule + , mbLocation :: (Maybe Location) + , mbComment :: (Maybe ByteString)} + deriving (Show,Read) + +instance Eq IdentifierDescr where + (==) a b = identifierID a == identifierID b + && typeInfo a == typeInfo b + +instance Ord IdentifierDescr where + (<=) a b = if identifierID a == identifierID b + then typeInfo a <= typeInfo b + else identifierID a < identifierID b + + +allFieldsID :: IdentifierDescr -> [Symbol] +allFieldsID (DataDescr _ _ _ _ fieldsId _ _) = fieldsId +allFieldsID _ = [] + +allConstructorsID :: IdentifierDescr -> [Symbol] +allConstructorsID (DataDescr _ _ _ constructorsID _ _ _) = constructorsID +allConstructorsID _ = [] + +allClassOpsID :: IdentifierDescr -> [Symbol] +allClassOpsID (ClassDescr _ _ _ classOpsID _ _) = classOpsID +allClassOpsID _ = [] + +typeInfo :: IdentifierDescr -> TypeInfo +typeInfo (SimpleDescr _ _ ti _ _ _) = ti +typeInfo (DataDescr _ ti _ _ _ _ _) = ti +typeInfo (ClassDescr _ ti _ _ _ _) = ti +typeInfo (InstanceDescr _ _ _ _ _) = BS.pack "" + +idDescriptionsPD :: PackageDescr -> [IdentifierDescr] +idDescriptionsPD pd = concatMap idDescriptionsMD (exposedModulesPD pd) + +instance Default IdentifierDescr where + getDefault = SimpleDescr getDefault getDefault getDefault getDefault getDefault + getDefault + +data IdType = Function | Newtype | Type | AbstractData | OpenData | Foreign + | Data | Class | Instance | Constructor | Field | Method | OrphanedInstance + deriving (Show, Eq, Ord, Enum, Read) + +instance Default IdType where + getDefault = Function + +data IdTypeS = FunctionS | NewtypeS | TypeS | AbstractDataS | OpenDataS | ForeignS + deriving (Show, Eq, Ord, Enum, Read) + +instance Default IdTypeS where + getDefault = FunctionS + +idType :: IdentifierDescr -> IdType +idType (SimpleDescr _ stype _ _ _ _) = case stype of + FunctionS -> Function + NewtypeS -> Newtype + TypeS -> Type + AbstractDataS -> AbstractData + OpenDataS -> OpenData + ForeignS -> Foreign +idType (DataDescr _ _ _ _ _ _ _) = Data +idType (ClassDescr _ _ _ _ _ _) = Class +idType (InstanceDescr _ _ _ _ _) = Instance + +type Symbol = String -- Qualified or unqualified +type ClassId = String -- Qualified or unqualified +type DataId = String -- Qualified or unqualified +type TypeInfo = ByteString +type ModuleIdentifier = String -- always qualified + +data PackModule = PM { pack :: PackageIdentifier + , modu :: ModuleIdentifier} + deriving (Eq, Ord,Read,Show) + + + +showPackModule :: PackModule -> String +showPackModule (PM p m) = showPackageId p ++ ":" ++ m + +parsePackModule :: String -> PackModule +parsePackModule str = let (pack',mod') = span (\c -> c /= ':') str + in if null (tail mod') + then perror str + else case toPackageIdentifier $ pack' of + Nothing -> perror str + Just pi'-> (PM pi' (tail mod')) + where perror s = throwIDE $ "cannot parse PackModule from " ++ s + +fromPackageIdentifier :: PackageIdentifier -> String +fromPackageIdentifier = showPackageId + +toPackageIdentifier :: String -> Maybe PackageIdentifier +toPackageIdentifier pd = let l = filter (\ (_,s) -> null s) + $ readP_to_S parsePackageId pd + in if null l + then Nothing + else Just (fst $ head l) + +instance Default PackModule where + getDefault = parsePackModule "unknow-0:Undefined" + +data Location = Location { + locationSLine :: Int +, locationSCol :: Int +, locationELine :: Int +, locationECol :: Int +} deriving (Show,Eq,Ord,Read) + +instance Default ByteString + where getDefault = BS.empty + +data Scope = World | Package | Local + deriving (Show, Eq, Ord, Enum, Read) + +newtype CandyTable = CT (CandyTableForth,CandyTableBack) + +type CandyTableForth = [(Bool,String,String)] + +type CandyTableBack = [(String,String,Int)] + +newtype KeymapI = KM (Map ActionString + [(Maybe (Either KeyString (KeyString,KeyString)), Maybe String)]) + +type SpecialKeyTable alpha = Map (KeyVal,[Modifier]) (Map (KeyVal,[Modifier]) (ActionDescr alpha)) + +type SpecialKeyCons alpha = Maybe ((Map (KeyVal,[Modifier]) (ActionDescr alpha)),String) + + + + + diff --git a/src/IDE/DescriptionPP.hs b/src/IDE/DescriptionPP.hs new file mode 100644 --- /dev/null +++ b/src/IDE/DescriptionPP.hs @@ -0,0 +1,95 @@ +----------------------------------------------------------------------------- +-- +-- Module : IDE.DescriptionPP +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | Description with additional fileds for printing and parsing +-- +----------------------------------------------------------------------------------- +module IDE.DescriptionPP ( + Applicator +, FieldDescriptionPP(..) +, mkFieldPP + +) where + +import Graphics.UI.Gtk hiding (Event) +import Control.Monad +import qualified Text.PrettyPrint.HughesPJ as PP +import qualified Text.ParserCombinators.Parsec as P + +import IDE.PrinterParser hiding (fieldParser,parameters) +import IDE.Framework.Parameters +import IDE.Framework.EditorBasics +import IDE.Core.State + +type Applicator alpha = alpha -> IDEAction + +data FieldDescriptionPP alpha = FDPP { + parameters :: Parameters + , fieldPrinter :: alpha -> PP.Doc + , fieldParser :: alpha -> P.CharParser () alpha + , fieldEditor :: alpha -> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier) + , applicator :: alpha -> alpha -> IDEAction + } + +type MkFieldDescriptionPP alpha beta = + Parameters -> + (Printer beta) -> + (Parser beta) -> + (Getter alpha beta) -> + (Setter alpha beta) -> + (Editor beta) -> + (Applicator beta) -> + FieldDescriptionPP alpha + +mkFieldPP :: Eq beta => MkFieldDescriptionPP alpha beta +mkFieldPP parameters printer parser getter setter editor applicator = + FDPP parameters + (\ dat -> (PP.text (case getParameterPrim paraName parameters of + Nothing -> "" + Just str -> str) PP.<> PP.colon) + PP.$$ (PP.nest 15 (printer (getter dat))) + PP.$$ (PP.nest 5 (case getParameterPrim paraSynopsis parameters of + Nothing -> PP.empty + Just str -> PP.text $"--" ++ str))) + (\ dat -> P.try (do + symbol (case getParameterPrim paraName parameters of + Nothing -> "" + Just str -> str) + colon + val <- parser + return (setter val dat))) + (\ dat -> do + (widget, inj,ext,noti) <- editor parameters + inj (getter dat) + noti FocusOut (Left (\e -> do + v <- ext + case v of + Just _ -> do + widgetModifyFg widget StateNormal (Color 0 0 0) + return False + Nothing -> do + widgetModifyFg widget StateNormal (Color 65535 65535 0) + return False)) + return (widget, + (\a -> inj (getter a)), + (\a -> do + b <- ext + case b of + Just b -> return (Just (setter b a)) + Nothing -> return Nothing), + noti)) + (\ newDat oldDat -> do --appicator + let newField = getter newDat + let oldField = getter oldDat + if newField == oldField + then return () + else applicator newField) + + diff --git a/src/IDE/FindPane.hs b/src/IDE/FindPane.hs new file mode 100644 --- /dev/null +++ b/src/IDE/FindPane.hs @@ -0,0 +1,361 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.FindPane +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | The pane of ide for searching in a text buffer +-- +------------------------------------------------------------------------------- + +module IDE.FindPane ( + IDEFind(..) +, FindAction(..) +, FindState(..) +, editFind +) where + +import Graphics.UI.Gtk hiding (get) +import Graphics.UI.Gtk.SourceView +import Data.Maybe +import Control.Monad.Reader +import Data.List + +import IDE.Core.State +import IDE.Framework.ViewFrame +import IDE.SourceEditor + +------------------------------------------------------------------------------- +-- +-- * Interface +-- + +class FindAction alpha where + doFind :: alpha + editFindInc :: SearchHint -> alpha + editFindKey :: Event -> alpha + editGotoLine :: alpha + editGotoLineEnd :: alpha + editGotoLineKey :: Event -> alpha + +instance FindAction IDEAction where + doFind = doFind' + editFindInc = editFindInc' + editFindKey = editFindKey' + editGotoLine = editGotoLine' + editGotoLineEnd = editGotoLineEnd' + editGotoLineKey = editGotoLineKey' + +instance IDEObject IDEFind + +instance CastablePane IDEFind where + casting _ = FindCasting + downCast _ (PaneC a) = case casting a of + FindCasting -> Just a + _ -> Nothing + + +instance Recoverable FindState where + toPaneState a = FindSt a + +instance Pane IDEFind + where + primPaneName _ = "Find" + getAddedIndex _ = 0 + getTopWidget = castToWidget . findBox + paneId b = "*Find" + makeActive p = throwIDE "don't activate find bar" + close pane = do + (panePath,_) <- guiPropertiesFromName (paneName pane) + nb <- getNotebook panePath + mbI <- lift $notebookPageNum nb (getTopWidget pane) + case mbI of + Nothing -> lift $ do + sysMessage Normal "notebook page not found: unexpected" + return () + Just i -> do + lift $notebookRemovePage nb i + removePaneAdmin pane + + +instance RecoverablePane IDEFind FindState where + saveState p = do + mbFind <- getPane FindCasting + case mbFind of + Nothing -> return Nothing + Just p -> lift $ do + return (Just (StateC FindState)) + recoverState pp FindState = do + nb <- getNotebook pp + initFind pp nb + +------------------------------------------------------------------------------- +-- +-- * Implementation +-- + +doFind' :: IDEAction +doFind' = do + find :: IDEFind <- getFind + lift $ bringPaneToFront find + lift $ widgetGrabFocus (getTopWidget find) + + +getFind :: IDEM IDEFind +getFind = do + mbFind <- getPane FindCasting + case mbFind of + Nothing -> do + prefs <- readIDE prefs + layout <- readIDE layout + let pp = getStandardPanePath (controlPanePath prefs) layout + nb <- getNotebook pp + initFind pp nb + mbFind <- getPane FindCasting + case mbFind of + Nothing -> throwIDE "Can't init find pane" + Just m -> return m + Just m -> return m + +initFind :: PanePath -> Notebook -> IDEAction +initFind panePath nb = do + ideR <- ask + panes <- readIDE panes + paneMap <- readIDE paneMap + prefs <- readIDE prefs + currentInfo <- readIDE currentInfo + (buf,cids) <- lift $ do + hBox <- hBoxNew False 10 + bBox <- hButtonBoxNew + + entry <- entryNew + widgetSetName entry "searchEntry" + + caseSensitiveButton <- toggleButtonNew + buttonSetLabel caseSensitiveButton "Case sensitive" + widgetSetName caseSensitiveButton "caseSensitiveButton" + + entireWordButton <- toggleButtonNew + buttonSetLabel entireWordButton "Entire word" + widgetSetName entireWordButton "entireWordButton" + + wrapAroundButton <- toggleButtonNew + buttonSetLabel wrapAroundButton "Wrap around" + toggleButtonSetActive wrapAroundButton True + widgetSetName wrapAroundButton "wrapAroundButton" + + spinL <- spinButtonNewWithRange 1.0 1000.0 10.0 + widgetSetName spinL "gotoLineEntry" + + boxPackStart hBox entry PackNatural 10 + boxPackStart bBox caseSensitiveButton PackNatural 10 + boxPackStart bBox entireWordButton PackNatural 10 + boxPackStart bBox wrapAroundButton PackNatural 10 + boxPackStart hBox bBox PackNatural 10 + boxPackStart hBox spinL PackNatural 10 + + entry `afterInsertText` (\ _ _ -> do + runReaderT ((editFindInc Insert)::IDEAction) ideR + t <- entryGetText entry + return (length t)) + entry `afterDeleteText` (\ _ _ -> do runReaderT ((editFindInc Delete)::IDEAction) + ideR; return ()) + entry `afterKeyPress` (\ e -> do runReaderT ((editFindKey e)::IDEAction) + ideR; return True) + spinL `afterKeyPress` (\ e -> do runReaderT ((editGotoLineKey e)::IDEAction) + ideR; return True) + spinL `afterEntryActivate` runReaderT editGotoLineEnd ideR + spinL `afterFocusOut` (\ _ -> do runReaderT (editGotoLineEnd::IDEAction) ideR; + return False) + let find = IDEFind hBox caseSensitiveButton wrapAroundButton entireWordButton + spinL entry + notebookInsertOrdered nb hBox (paneName find) + widgetShowAll hBox + return (find,[]) + addPaneAdmin buf (BufConnections [] [] []) panePath + lift $widgetGrabFocus (findBox buf) + +getFindEntry' :: IDEFind -> Entry +getFindEntry' f = findEntry f + +getCaseSensitive' :: IDEFind -> ToggleButton +getCaseSensitive' f = caseSensitive f + +getWrapAround' :: IDEFind -> ToggleButton +getWrapAround' f = wrapAround f + +getEntireWord' :: IDEFind -> ToggleButton +getEntireWord' f = entireWord f + +getGotoLineSpin' :: IDEFind -> SpinButton +getGotoLineSpin' f = gotoLine f + +red = Color 640000 10000 10000 +white = Color 64000 64000 64000 +black = Color 0 0 0 + +{-- can't be used currently becuase of an export error + toEnum 1 = SourceSearchVisibleOnly + toEnum 2 = SourceSearchTextOnly + toEnum 4 = SourceSearchCaseInsensitive +--} + + +-- | Keys for searching +editFindKey' :: Event -> IDEAction +editFindKey' k@(Key _ _ _ _ _ _ _ _ _ _) + | eventKeyName k == "Down" = + editFindInc Forward + | eventKeyName k == "Up" = + editFindInc Backward + | eventKeyName k == "Escape" = do + --entry <- getFindEntry + inBufContext' () $ \_ gtkbuf currentBuffer _ -> lift $ do + i1 <- textBufferGetStartIter gtkbuf + i2 <- textBufferGetEndIter gtkbuf + textBufferRemoveTagByName gtkbuf "found" i1 i2 + startMark <- textBufferGetInsert gtkbuf + st1 <- textBufferGetIterAtMark gtkbuf startMark + textBufferPlaceCursor gtkbuf st1 + widgetGrabFocus $ sourceView currentBuffer + | otherwise = return () +editFindKey' _ = return () + +editFindInc' :: SearchHint -> IDEAction +editFindInc' hint = do + find :: IDEFind <- getFind + let entry = getFindEntry' find + lift $ widgetGrabFocus entry + lift $ bringPaneToFront find + when (hint == Initial) $ lift $ editableSelectRegion entry 0 (-1) + search <- lift $entryGetText entry + if null search + then return () + else do + let caseSensitiveW = getCaseSensitive' find + caseSensitive <- lift $toggleButtonGetActive caseSensitiveW + let entireWButton = getEntireWord' find + entireW <- lift $toggleButtonGetActive entireWButton + let wrapAroundButton = getWrapAround' find + wrapAround <- lift $toggleButtonGetActive wrapAroundButton + res <- editFind entireW caseSensitive wrapAround search "" hint + if res || null search + then lift $do + widgetModifyBase entry StateNormal white + widgetModifyText entry StateNormal black + else lift $do + widgetModifyBase entry StateNormal red + widgetModifyText entry StateNormal white + lift $do + widgetGrabFocus entry + editableSelectRegion entry 0 (-1) + + +editFind :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool +editFind entireWord caseSensitive wrapAround search dummy hint = + let searchflags = (if caseSensitive then [] else [toEnum 4]) ++ [toEnum 1,toEnum 2] in + if null search + then return False + else inBufContext' False $ \_ gtkbuf currentBuffer _ -> lift $ do + i1 <- textBufferGetStartIter gtkbuf + i2 <- textBufferGetEndIter gtkbuf + textBufferRemoveTagByName gtkbuf "found" i1 i2 + startMark <- textBufferGetInsert gtkbuf + st1 <- textBufferGetIterAtMark gtkbuf startMark + mbsr2 <- + if hint == Backward + then do + textIterBackwardChar st1 + textIterBackwardChar st1 + mbsr <- backSearch st1 search searchflags entireWord searchflags + case mbsr of + Nothing -> + if wrapAround + then do backSearch i2 search searchflags entireWord searchflags + else return Nothing + Just (start,end) -> return (Just (start,end)) + else do + if hint == Forward + then textIterForwardChar st1 + else return True + mbsr <- forwardSearch st1 search searchflags entireWord searchflags + case mbsr of + Nothing -> + if wrapAround + then do forwardSearch i1 search searchflags entireWord searchflags + else return Nothing + Just (start,end) -> return (Just (start,end)) + case mbsr2 of + Just (start,end) -> do --found + --widgetGrabFocus sourceView + textViewScrollToIter (sourceView currentBuffer) start 0.2 Nothing + textBufferApplyTagByName gtkbuf "found" start end + textBufferPlaceCursor gtkbuf start + return True + Nothing -> return False + where + backSearch iter string flags entireWord searchflags = do + mbsr <- sourceIterBackwardSearch iter search searchflags Nothing + case mbsr of + Nothing -> return Nothing + Just (iter1,iter2) -> + if entireWord + then do + b1 <- textIterStartsWord iter1 + b2 <- textIterEndsWord iter2 + if b1 && b2 then return $Just (iter1,iter2) else return Nothing + else return (Just (iter1,iter2)) + forwardSearch iter string flags entireWord searchflags = do + mbsr <- sourceIterForwardSearch iter search searchflags Nothing + case mbsr of + Nothing -> return Nothing + Just (iter1,iter2) -> + if entireWord + then do + b1 <- textIterStartsWord iter1 + b2 <- textIterEndsWord iter2 + if b1 && b2 then return $Just (iter1,iter2) else return Nothing + else return $Just (iter1,iter2) + +editGotoLine' :: IDEAction +editGotoLine' = inBufContext' () $ \_ gtkbuf currentBuffer _ -> do + find :: IDEFind <- getFind + let spin = getGotoLineSpin' find + lift $ bringPaneToFront find + lift $do + max <- textBufferGetLineCount gtkbuf + spinButtonSetRange spin 1.0 (fromIntegral max) + widgetGrabFocus spin + +editGotoLineKey' :: Event -> IDEAction +editGotoLineKey' k@(Key _ _ _ _ _ _ _ _ _ _) + | eventKeyName k == "Escape" = + inBufContext' () $ \_ gtkbuf currentBuffer _ -> do + find :: IDEFind <- getFind + let spin = getGotoLineSpin' find + lift $ do + widgetGrabFocus $ sourceView currentBuffer + | otherwise = return () +editGotoLineKey' _ = return () + +editGotoLineEnd' :: IDEAction +editGotoLineEnd' = inBufContext' () $ \_ gtkbuf currentBuffer _ -> do + find :: IDEFind <- getFind + let spin = getGotoLineSpin' find + lift $ bringPaneToFront find + lift $ do + line <- spinButtonGetValueAsInt spin + iter <- textBufferGetStartIter gtkbuf + textIterSetLine iter (line - 1) + textBufferPlaceCursor gtkbuf iter + textViewScrollToIter (sourceView currentBuffer) iter 0.2 Nothing + widgetGrabFocus $ sourceView currentBuffer + + + + diff --git a/src/IDE/Framework/CompositeEditors.hs b/src/IDE/Framework/CompositeEditors.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Framework/CompositeEditors.hs @@ -0,0 +1,402 @@ +----------------------------------------------------------------------------- +-- +-- Module : IDE.Framework.CompositeEditors +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | Module for making composite editors +-- +----------------------------------------------------------------------------------- + +module IDE.Framework.CompositeEditors ( + maybeEditor +, pairEditor +, eitherOrEditor +, multisetEditor +, ColumnDescr(..) +) where + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.ModelView as New +import Control.Monad +import Data.IORef +import Data.Maybe + +import IDE.Utils.Default +import IDE.Core.Exception +import IDE.Framework.Parameters +import IDE.Framework.EditorBasics +import IDE.Framework.MakeEditor +import IDE.Framework.SimpleEditors + +-- +-- | An editor which composes two subeditors +-- +pairEditor :: (Editor alpha, Parameters) -> (Editor beta, Parameters) -> Editor (alpha,beta) +pairEditor (fstEd,fstPara) (sndEd,sndPara) parameters = do + coreRef <- newIORef Nothing + notifier <- emptyNotifier + declareEvent FocusOut (\w h -> w `onFocusOut` do h) notifier + mkEditor + (\widget (v1,v2) -> do + core <- readIORef coreRef + case core of + Nothing -> do + fst@(fstFrame,inj1,ext1,noti1) <- fstEd fstPara + snd@(sndFrame,inj2,ext2,noti2) <- sndEd sndPara + box <- case getParameter paraDirection parameters of + Horizontal -> do + b <- hBoxNew False 1 + return (castToBox b) + Vertical -> do + b <- vBoxNew False 1 + return (castToBox b) + boxPackStart box fstFrame PackGrow 0 + boxPackStart box sndFrame PackGrow 0 + containerAdd widget box + propagateEvent FocusOut noti2 notifier + inj1 v1 + inj2 v2 + writeIORef coreRef (Just (fst,snd)) + Just ((_,inj1,_,_),(_,inj2,_,_)) -> do + inj1 v1 + inj2 v2) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just ((_,_,ext1,_),(_,_,ext2,_)) -> do + r1 <- ext1 + r2 <- ext2 + if isJust r1 && isJust r2 + then return (Just (fromJust r1,fromJust r2)) + else return Nothing) + (mkNotifier notifier) + parameters + +-- +-- | An editor with a subeditor which gets active, when a checkbox is selected +-- or deselected (if the positive Argument is False) +-- +maybeEditor :: Default beta => (Editor beta, Parameters) -> Bool -> String -> Editor (Maybe beta) +maybeEditor (childEdit, childParams) positive boolLabel parameters = do + coreRef <- newIORef Nothing + childRef <- newIORef Nothing + notifier <- emptyNotifier + declareEvent FocusOut (\w h -> w `onFocusOut` do h) notifier + mkEditor + (\widget mbVal -> do + core <- readIORef coreRef + case core of + Nothing -> do + be@(boolFrame,inj1,ext1,notifierBool) <- boolEditor + (paraName <<<- (ParaName boolLabel) $ emptyParams) + propagateEvent FocusOut notifierBool notifier + box <- case getParameter paraDirection parameters of + Horizontal -> do + b <- hBoxNew False 1 + return (castToBox b) + Vertical -> do + b <- vBoxNew False 1 + return (castToBox b) + boxPackStart box boolFrame PackNatural 0 + containerAdd widget box + notifierBool Clicked (Left (onClickedHandler widget coreRef childRef notifier)) + case mbVal of + Nothing -> do + inj1 (if positive then False else True) + Just val -> do + (childWidget,inj2,ext2,noti2) <- getChildEditor childRef childEdit childParams notifier + boxPackEnd box childWidget PackNatural 0 + widgetShowAll childWidget + inj1 (if positive then True else False) + inj2 val + writeIORef coreRef (Just (be,box)) + Just (be@(boolFrame,inj1,ext1,notiRef1),box) -> do + hasChild <- hasChildEditor childRef + case mbVal of + Nothing -> do + if hasChild + then do + (childWidget,_,_,_) <- getChildEditor childRef childEdit childParams notifier + inj1 (if positive then False else True) + widgetHideAll childWidget + else inj1 (if positive then False else True) + Just val -> do + if hasChild + then do + (childWidget,inj2,_,_) <- getChildEditor childRef childEdit childParams notifier + widgetShowAll childWidget + inj2 val + else do + (childWidget,inj2,_,_) <- getChildEditor childRef childEdit childParams notifier + boxPackEnd box childWidget PackNatural 0 + widgetShowAll childWidget + inj2 val) + (do + core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just (be@(boolFrame,inj1,ext1,notiRef1),_) -> do + bool <- ext1 + case bool of + Nothing -> return Nothing + Just bv | bv == positive -> do + (_,_,ext2,_) <- getChildEditor childRef childEdit childParams notifier + value <- ext2 + case value of + Nothing -> return Nothing + Just value -> return (Just (Just value)) + otherwise -> return (Just Nothing)) + (mkNotifier notifier) + parameters + where + onClickedHandler widget coreRef childRef notifier = (\ event -> do + core <- readIORef coreRef + case core of + Nothing -> throwIDE "Impossible" + Just (be@(boolFrame,inj1,ext1,notiRef1),vBox) -> do + mbBool <- ext1 + case mbBool of + Just bool -> + if not (bool == positive) + then do + hasChild <- hasChildEditor childRef + if hasChild + then do + (childWidget,_,_,_) <- getChildEditor childRef childEdit childParams notifier + widgetHideAll childWidget + else return () + else do + hasChild <- hasChildEditor childRef + if hasChild + then do + (childWidget,_,_,_) <- getChildEditor childRef childEdit childParams notifier + widgetShowAll childWidget + else do + (childWidget,inj2,_,_) <- getChildEditor childRef childEdit childParams notifier + boxPackEnd vBox childWidget PackNatural 0 + inj2 getDefault + widgetShowAll childWidget + Nothing -> return () + return True) + getChildEditor childRef childEditor childParams notifier = do + mb <- readIORef childRef + case mb of + Just editor -> return editor + Nothing -> do + let val = childEditor + editor@(_,_,_,cnoti) <- childEditor childParams + propagateEvent FocusOut cnoti notifier + writeIORef childRef (Just editor) + return editor + hasChildEditor childRef = do + mb <- readIORef childRef + return (isJust mb) + +-- +-- | An editor with a subeditor which gets active, when a checkbox is selected +-- or deselected (if the positive Argument is False) +eitherOrEditor :: (Default alpha, Default beta) => (Editor alpha, Parameters) -> + (Editor beta, Parameters) -> String -> Editor (Either alpha beta) +eitherOrEditor (leftEditor,leftParams) (rightEditor,rightParams) label2 parameters = do + coreRef <- newIORef Nothing + notifier <- emptyNotifier + declareEvent FocusOut (\w h -> w `onFocusOut` do h) notifier + mkEditor + (\widget v -> do + core <- readIORef coreRef + case core of + Nothing -> do + be@(boolFrame,inj1,ext1,noti1) <- boolEditor2 label2 parameters + le@(leftFrame,inj2,ext2,noti2) <- leftEditor leftParams + re@(rightFrame,inj3,ext3,noti3) <- rightEditor rightParams + noti1 Clicked (Left (onClickedHandler widget coreRef)) + propagateEvent FocusOut noti2 notifier + propagateEvent FocusOut noti3 notifier + box <- case getParameter paraDirection parameters of + Horizontal -> do + b <- hBoxNew False 1 + return (castToBox b) + Vertical -> do + b <- vBoxNew False 1 + return (castToBox b) + boxPackStart box boolFrame PackNatural 0 + activateEvent (castToWidget box) FocusOut notifier + containerAdd widget box + case v of + Left vl -> do + boxPackStart box leftFrame PackNatural 0 + inj2 vl + inj3 getDefault + inj1 True + Right vr -> do + boxPackStart box rightFrame PackNatural 0 + inj3 vr + inj2 getDefault + inj1 False + writeIORef coreRef (Just (be,le,re,box)) + Just ((_,inj1,_,_),(leftFrame,inj2,_,_),(rightFrame,inj3,_,_),box) -> do + case v of + Left vl -> do + containerRemove box rightFrame + boxPackStart box leftFrame PackNatural 0 + inj2 vl + inj3 getDefault + inj1 True + Right vr -> do + containerRemove box leftFrame + boxPackStart box rightFrame PackNatural 0 + inj3 vr + inj2 getDefault + inj1 False) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just ((_,_,ext1,_),(_,_,ext2,_),(_,_,ext3,_),_) -> do + mbbool <- ext1 + case mbbool of + Nothing -> return Nothing + Just True -> do + value <- ext2 + case value of + Nothing -> return Nothing + Just value -> return (Just (Left value)) + Just False -> do + value <- ext3 + case value of + Nothing -> return Nothing + Just value -> return (Just (Right value))) + (mkNotifier notifier) + (paraName <<<- (ParaName "") $ parameters) + where + onClickedHandler widget coreRef = (\ event -> do + core <- readIORef coreRef + case core of + Nothing -> throwIDE "Impossible" + Just (be@(_,_,ext1,_),(leftFrame,_,_,_),(rightFrame,_,_,_),box) -> do + mbBool <- ext1 + case mbBool of + Just bool -> + if bool then do + containerRemove box rightFrame + boxPackStart box leftFrame PackNatural 0 + widgetShowAll box + else do + containerRemove box leftFrame + boxPackStart box rightFrame PackNatural 0 + widgetShowAll box + Nothing -> return () + return True) + + +-- a trivial example: (ColumnDescr False [("",(\row -> [New.cellText := show row]))]) +-- and a nontrivial: +-- [("Package",\(Dependency str _) -> [New.cellText := str]) +-- ,("Version",\(Dependency _ vers) -> [New.cellText := showVersionRange vers])]) +data ColumnDescr row = ColumnDescr Bool [(String,(row -> [AttrOp CellRendererText]))] + +-- +-- | An editor with a subeditor, of which a list of items can be selected +multisetEditor :: (Show alpha, Default alpha) => + ColumnDescr alpha -> (Editor alpha, Parameters) -> Editor [alpha] +multisetEditor (ColumnDescr showHeaders columnsDD) (singleEditor, sParams) parameters = do + coreRef <- newIORef Nothing + notifier <- emptyNotifier + declareEvent FocusOut (\w h -> w `onFocusOut` do h) notifier + mkEditor + (\widget v -> do + core <- readIORef coreRef + case core of + Nothing -> do + (box,buttonBox) <- case getParameter paraDirection parameters of + Horizontal -> do + b <- hBoxNew False 1 + bb <- vButtonBoxNew + return (castToBox b,castToButtonBox bb) + Vertical -> do + b <- vBoxNew False 1 + bb <- hButtonBoxNew + return (castToBox b,castToButtonBox bb) + (frameS,injS,extS,notS) <- singleEditor sParams + addButton <- buttonNewWithLabel "Add" + removeButton <- buttonNewWithLabel "Remove" + containerAdd buttonBox addButton + containerAdd buttonBox removeButton + listStore <- New.listStoreNew ([]:: [alpha]) + list <- New.treeViewNewWithModel listStore + widgetSetSizeRequest list 50 50 + sel <- New.treeViewGetSelection list + New.treeSelectionSetMode sel SelectionSingle + mapM_ (\(str,func) -> do + col <- New.treeViewColumnNew + New.treeViewColumnSetTitle col str + New.treeViewColumnSetResizable col True + New.treeViewAppendColumn list col + renderer <- New.cellRendererTextNew + New.cellLayoutPackStart col renderer True + New.cellLayoutSetAttributes col renderer listStore func + ) columnsDD + New.treeViewSetHeadersVisible list showHeaders + sel `New.onSelectionChanged` (selectionHandler sel listStore injS) + boxPackStart box list PackNatural 0 + boxPackStart box buttonBox PackNatural 0 + boxPackEnd box frameS PackGrow 0 + activateEvent (castToWidget list) FocusOut notifier + containerAdd widget box + New.listStoreClear listStore + mapM_ (New.listStoreAppend listStore) v + addButton `onClicked` do + mbv <- extS + case mbv of + Just v -> do + New.listStoreAppend listStore v + return () + Nothing -> return () + removeButton `onClicked` do + mbi <- New.treeSelectionGetSelected sel + case mbi of + Nothing -> return () + Just iter -> do + [i] <- New.treeModelGetPath listStore iter + New.listStoreRemove listStore i + writeIORef coreRef (Just listStore) + injS getDefault + Just listStore -> do + New.listStoreClear listStore + mapM_ (New.listStoreAppend listStore) v) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just listStore -> do + v <- listStoreGetValues listStore + return (Just v)) + (mkNotifier notifier) + parameters + where + listStoreGetValues :: New.ListStore a -> IO [a] + listStoreGetValues listStore = do + mbi <- New.treeModelGetIterFirst listStore + getTail mbi + where getTail mbi = case mbi of + Nothing -> return [] + Just iter -> do + [i] <- New.treeModelGetPath listStore iter + v <- New.listStoreGetValue listStore i + mbi2 <- New.treeModelIterNext listStore iter + rest <- getTail mbi2 + return (v : rest) + selectionHandler :: New.TreeSelection -> New.ListStore a -> Injector a -> IO () + selectionHandler sel listStore inj = do + ts <- New.treeSelectionGetSelected sel + case ts of + Nothing -> return () + Just iter -> do + [i] <- New.treeModelGetPath listStore iter + v <- New.listStoreGetValue listStore i + inj v + return () + diff --git a/src/IDE/Framework/EditorBasics.hs b/src/IDE/Framework/EditorBasics.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Framework/EditorBasics.hs @@ -0,0 +1,90 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Framework.EditorBasics +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | Module for the basiscs of composing GUIs from editors +-- +----------------------------------------------------------------------------------- + +module IDE.Framework.EditorBasics ( +-- * Types + Getter +, Setter +, Injector +, Extractor +, Editor +--, Applicator +, Handler +, Notifier +, EventSelector(..) +) where + +import Graphics.UI.Gtk --hiding (Event) +import Data.Unique + +import Graphics.UI.Gtk --hiding (Event) + +import IDE.Framework.Parameters + +-- --------------------------------------------------------------------- +-- * Basic Types +-- + +-- +-- | A type for getting a field of a record +-- +type Getter alpha beta = alpha -> beta +-- +-- | A type for setting the field of a record +-- +type Setter alpha beta = beta -> alpha -> alpha + +-- +-- | A type for injecting a value into an editor +-- +type Injector beta = beta -> IO() +-- +-- | A type for extracting a value from an editor +-- +type Extractor beta = IO(Maybe (beta)) + +--type Applicator beta = beta -> IDEAction () + +--class EventSource alpha where + +--class Event alpha where +-- event :: a -> Event + +-- +-- | A type for handling an IO event +-- Returning True: The event has been handles +-- Returning False: Handling should proceed +type Handler = Event -> IO Bool + +data EventSelector = Clicked + | FocusOut + | FocusIn + | SelectionChanged + | ButtonRelease + deriving (Eq,Ord,Show) + +-- +-- | A type to register or unregister a handler +-- If the second argument is Left Handler the handler gets registered +-- If the second argument is Right Unique the handler will be removed +-- The returned unique value must be used for unregistering an event +type Notifier = EventSelector -> Either Handler Unique -> IO (Unique) + +-- +-- | A type to describe an editor. +-- alpha is the type of the individual field of the record +type Editor alpha = Parameters -> IO(Widget, Injector alpha , Extractor alpha , Notifier) + + diff --git a/src/IDE/Framework/MakeEditor.hs b/src/IDE/Framework/MakeEditor.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Framework/MakeEditor.hs @@ -0,0 +1,265 @@ +----------------------------------------------------------------------------- +-- +-- Module : IDE.Framework.MakeEditor +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | Module for making editors out of descriptions +-- +----------------------------------------------------------------------------------- + +module IDE.Framework.MakeEditor ( + + FieldDescription(..) +, mkField +, emptyNotifier +, EventSelector(..) +, extractAndValidate +, extract +, mkEditor + +, declareEvent +, activateEvent +, propagateEvent +, mkNotifier + +) where + +import Graphics.UI.Gtk hiding (Event) +import Control.Monad +import Data.IORef +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Unique + +import IDE.Core.Exception +import IDE.Framework.Parameters +import IDE.Framework.EditorBasics + +-- +-- | A constructor type for a field desciption +-- +type MkFieldDescription alpha beta = + Parameters -> + (Getter alpha beta) -> + (Setter alpha beta) -> + (Editor beta) -> + FieldDescription alpha + +-- +-- | A type to describe a field of a record, which can be edited +-- | alpha is the type of the individual field of the record +data FieldDescription alpha = FD { + parameters :: Parameters + , fieldEditor :: alpha -> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier) + } + +-- ------------------------------------------------------------ +-- * Implementation of editing +-- ------------------------------------------------------------ + +-- +-- | Function to construct a field description +-- +mkField :: Eq beta => MkFieldDescription alpha beta +mkField parameters getter setter editor = + FD parameters + (\ dat -> do + (widget, inj,ext,noti) <- editor parameters + inj (getter dat) + noti FocusOut (Left (\e -> do + v <- ext + case v of + Just _ -> do + return False + Nothing -> do + sysMessage Normal "Validation Failure" + let message = case getParameterPrim paraName parameters of + Just s -> "in field " ++ s + Nothing -> "in unnamed field" + dia <- messageDialogNew Nothing [] MessageWarning ButtonsClose + ("Validation Failure " ++ message) + dialogRun dia + widgetDestroy dia + return False)) + return (widget, + (\a -> inj (getter a)), + (\a -> do + b <- ext + case b of + Just b -> return (Just (setter b a)) + Nothing -> return Nothing), + noti)) + +-- | Function to construct an editor +-- +mkEditor :: (Container -> Injector alpha) -> Extractor alpha -> Notifier -> Editor alpha +mkEditor injectorC extractor notifier parameters = do + let (xalign, yalign, xscale, yscale) = getParameter paraOuterAlignment parameters + outerAlig <- alignmentNew xalign yalign xscale yscale + let (paddingTop, paddingBottom, paddingLeft, paddingRight) = getParameter paraOuterPadding parameters + alignmentSetPadding outerAlig paddingTop paddingBottom paddingLeft paddingRight + frame <- frameNew + frameSetShadowType frame (getParameter paraShadow parameters) + case getParameter paraName parameters of + "" -> return () + str -> frameSetLabel frame str + containerAdd outerAlig frame + let (xalign, yalign, xscale, yscale) = getParameter paraInnerAlignment parameters + innerAlig <- alignmentNew xalign yalign xscale yscale + let (paddingTop, paddingBottom, paddingLeft, paddingRight) = getParameter paraInnerPadding parameters + alignmentSetPadding innerAlig paddingTop paddingBottom paddingLeft paddingRight + containerAdd frame innerAlig + let (x,y) = getParameter paraMinSize parameters + widgetSetSizeRequest outerAlig x y + return ((castToWidget) outerAlig, injectorC (castToContainer innerAlig), extractor, notifier) + +-- | Convenience method to validate and extract fields +-- +extractAndValidate :: alpha -> [alpha -> Extractor alpha] -> [String] -> IO (Maybe alpha) +extractAndValidate val getExts fieldNames = do + (newVal,errors) <- foldM (\ (val,errs) (ext,fn) -> do + extVal <- ext val + case extVal of + Just nval -> return (nval,errs) + Nothing -> return (val, (' ' : fn) : errs)) + (val,[]) (zip getExts fieldNames) + if null errors + then return (Just newVal) + else do + md <- messageDialogNew Nothing [] MessageWarning ButtonsClose + $ "The following fields have invalid values." ++ + concat (reverse errors) + dialogRun md + widgetDestroy md + return Nothing + +extract :: alpha -> [alpha -> Extractor alpha] -> IO (Maybe alpha) +extract val getExts = + foldM (\ mbVal ext -> do + case mbVal of + Nothing -> return Nothing + Just val -> do + newVal <- ext val + return newVal) + (Just val) getExts + +-- ------------------------------------------------------------ +-- * Implementation of notifications +-- ------------------------------------------------------------ + +-- +-- | A type for a function to register an event +-- +type RegFunc = Widget -> Handler -> IO (ConnectId Widget) + +-- +-- | A type for the state of the notification system +-- +type NotifierSt = IORef (Map EventSelector + (Maybe Widget,RegFunc,Maybe (ConnectId Widget),[(Unique, Handler)])) + +-- +-- | Initial state of the notification system +-- +emptyNotifier :: IO (NotifierSt) +emptyNotifier = newIORef(Map.empty) + +-- +-- | Declare that the event can be thrown from this editor +-- +declareEvent :: EventSelector -> RegFunc -> NotifierSt -> IO() +declareEvent eventSel regFunc notifierState = do + noti <- readIORef notifierState + case Map.lookup eventSel noti of + Nothing -> do + let noti2 = Map.insert eventSel (Nothing, regFunc, Nothing,[]) noti + writeIORef notifierState noti2 + Just _ -> throwIDE $"editor has already declared event " ++ show eventSel + +-- +-- | Activate the event after the widget has been constructed +-- +activateEvent :: Widget -> EventSelector -> NotifierSt -> IO() +activateEvent widget eventSel notifierState = do + noti <- readIORef notifierState + case Map.lookup eventSel noti of + Nothing -> throwIDE $"editor has not declared event before activating it " ++ show eventSel + Just (Nothing,registerFunc,Nothing,handlers) -> do + cid <- registerFunc widget (\ e -> do + noti <- readIORef notifierState + case Map.lookup eventSel noti of + Nothing -> return False + Just (_,_,_,[]) -> return False + Just (_,_,_,handlers2) -> do + boolList <- mapM (\f -> f e) (map snd handlers2) + return (foldl (&&) True boolList)) + let noti2 = Map.insert eventSel (Just widget,registerFunc,Just cid,handlers) noti + writeIORef notifierState noti2 + Just _ -> throwIDE $"editor has already been activated " ++ show eventSel + +-- +-- | Propagate the event with the selector from notifier to notifierst +-- +propagateEvent :: EventSelector -> Notifier -> NotifierSt -> IO() +propagateEvent eventSel notiFrom notifierState = do + noti <- readIORef notifierState + case Map.lookup eventSel noti of + Nothing -> throwIDE $"can't propagte event which is not activated " ++ show eventSel + Just (mbWidget,registerFunc,Nothing,handlers) -> do + cid <- notiFrom eventSel (Left (\ e -> do + noti <- readIORef notifierState + case Map.lookup eventSel noti of + Nothing -> return False + Just (_,_,_,[]) -> return False + Just (_,_,_,handlers2) -> do + boolList <- mapM (\f -> f e) (map snd handlers2) + return (foldl (&&) True boolList))) + let noti2 = Map.insert eventSel (mbWidget,registerFunc,Nothing,handlers) noti + writeIORef notifierState noti2 + Just _ -> throwIDE $"editor has already been activated " ++ show eventSel + +-- +-- | Constructor for a notifier +-- +mkNotifier :: NotifierSt -> Notifier +mkNotifier notifierState = notFunc + where + notFunc :: EventSelector -> Either Handler Unique -> IO (Unique) + notFunc eventSel (Left handler) = do + noti <- readIORef notifierState + uni <- newUnique + case Map.lookup eventSel noti of + Nothing -> throwIDE $"editor does not support event " ++ show eventSel + Just (Just widget,registerFunc,Nothing,handlers) + -> throwIDE $"mkNotifier for activated event" ++ show eventSel + Just (mbWidget, registerFunc, mbUnique, handlers) + -> do unique <- newUnique + let noti2 = Map.insert eventSel + (mbWidget,registerFunc,mbUnique,handlers++[(uni,handler)]) noti + writeIORef notifierState noti2 + return unique + notFunc eventSel (Right uni) = do + noti <- readIORef notifierState + case Map.lookup eventSel noti of + Nothing -> throwIDE $"editor does not support event " ++ show eventSel + Just (mbWidget,regFunc,Just cid,l) -> do + let l2 = filter (\(u,_) -> u /= uni) l + if null l2 + then do + signalDisconnect cid + let noti2 = Map.insert eventSel (mbWidget,regFunc,Nothing,[]) noti + writeIORef notifierState noti2 + else do + let noti2 = Map.insert eventSel (mbWidget,regFunc,Just cid,l2) noti + writeIORef notifierState noti2 + _ -> return () + return uni + + + + diff --git a/src/IDE/Framework/Parameters.hs b/src/IDE/Framework/Parameters.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Framework/Parameters.hs @@ -0,0 +1,148 @@ +----------------------------------------------------------------------------- +-- +-- Module : IDE.Framework.Parameters +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | Module for parameters for editors +-- +----------------------------------------------------------------------------------- + +module IDE.Framework.Parameters ( + Parameters +, Parameter(..) +, paraName +, paraSynopsis +, paraDirection +, paraShadow +, paraOuterAlignment +, paraInnerAlignment +, paraOuterPadding +, paraInnerPadding +, paraMinSize +, paraHorizontal +, getParameter +, getParameterPrim +, (<<<-) +, emptyParams +, Direction(..) +, HorizontalAlign(..) +) where + +import Graphics.UI.Gtk +import Data.Maybe +import qualified Data.List as List + +import IDE.Core.Exception + +-- +-- | The direction of a split +-- +data Direction = Horizontal | Vertical + deriving (Eq,Show) + +data HorizontalAlign = StartHorizontal | StopHorizontal | Keep + deriving (Eq,Show) +-- +-- | A type for parameters for editors +-- +type Parameters = [Parameter] + +data Parameter = ParaName String + | ParaSynopsis String + | ParaDirection Direction + | ParaShadow ShadowType + | ParaOuterAlignment (Float,Float,Float,Float) + -- | xalign yalign xscale yscale + | ParaOuterPadding (Int,Int,Int,Int) + -- | paddingTop paddingBottom paddingLeft paddingRight + | ParaInnerAlignment (Float,Float,Float,Float) + -- | xalign yalign xscale yscale + | ParaInnerPadding (Int,Int,Int,Int) + -- | paddingTop paddingBottom paddingLeft paddingRight + | ParaMinSize (Int, Int) + | ParaHorizontal HorizontalAlign + deriving (Eq,Show) + +instance Show ShadowType + where show _ = "Any Shadow" + +emptyParams :: [Parameter] +emptyParams = [] + +paraName :: (Parameter -> (Maybe String)) +paraName (ParaName str) = Just str +paraName _ = Nothing + +paraSynopsis :: (Parameter -> (Maybe String)) +paraSynopsis (ParaSynopsis str) = Just str +paraSynopsis _ = Nothing + +paraDirection :: (Parameter -> (Maybe Direction)) +paraDirection (ParaDirection d) = Just d +paraDirection _ = Nothing + +paraShadow :: (Parameter -> (Maybe ShadowType)) +paraShadow (ParaShadow d) = Just d +paraShadow _ = Nothing + +paraOuterAlignment :: (Parameter -> (Maybe (Float,Float,Float,Float))) +paraOuterAlignment (ParaOuterAlignment d) = Just d +paraOuterAlignment _ = Nothing + +paraInnerAlignment :: (Parameter -> (Maybe (Float,Float,Float,Float))) +paraInnerAlignment (ParaInnerAlignment d) = Just d +paraInnerAlignment _ = Nothing + +paraOuterPadding :: (Parameter -> (Maybe (Int,Int,Int,Int))) +paraOuterPadding (ParaOuterPadding d) = Just d +paraOuterPadding _ = Nothing + +paraInnerPadding :: (Parameter -> (Maybe (Int,Int,Int,Int))) +paraInnerPadding (ParaInnerPadding d) = Just d +paraInnerPadding _ = Nothing + +paraMinSize :: (Parameter -> (Maybe (Int, Int))) +paraMinSize (ParaMinSize d) = Just d +paraMinSize _ = Nothing + +paraHorizontal :: (Parameter -> (Maybe (HorizontalAlign))) +paraHorizontal (ParaHorizontal d) = Just d +paraHorizontal _ = Nothing + +-- +-- | Convenience method to get a parameter, or if not set the default parameter +-- +getParameter :: (Parameter -> (Maybe beta)) -> Parameters -> beta +getParameter selector parameter = + case getParameterPrim selector parameter of + Just ele -> ele + _ -> case getParameterPrim selector defaultParameters of + Just ele -> ele + _ -> throwIDE "default parameter not defined" + +getParameterPrim :: (Parameter -> (Maybe beta)) -> Parameters -> Maybe beta +getParameterPrim selector parameter = + case filter isJust $ map selector parameter of + (Just ele) : _ -> Just ele + _ -> Nothing + +(<<<-) :: (Parameter -> (Maybe beta)) -> Parameter -> Parameters -> Parameters +(<<<-) selector para = \params -> para : filter (isNothing . selector) params + +defaultParameters :: Parameters +defaultParameters = + [ ParaName "" + , ParaSynopsis "" + , ParaDirection Horizontal + , ParaShadow ShadowNone + , ParaOuterAlignment (0.5, 0.5, 0.95, 0.95) + , ParaOuterPadding (2, 5, 3, 3) + , ParaInnerAlignment (0.5, 0.5, 0.95, 0.95) + , ParaInnerPadding (2, 5, 3, 3) + , ParaMinSize (-1,-1) + , ParaHorizontal Keep] diff --git a/src/IDE/Framework/SimpleEditors.hs b/src/IDE/Framework/SimpleEditors.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Framework/SimpleEditors.hs @@ -0,0 +1,561 @@ +----------------------------------------------------------------------------- +-- +-- Module : IDE.Framework.SimpleEditors +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | Module for making simple editors +-- +----------------------------------------------------------------------------------- + +module IDE.Framework.SimpleEditors ( + boolEditor +, boolEditor2 +, stringEditor +, multilineStringEditor +, intEditor +, genericEditor +, fontEditor +, staticSelectionEditor +, staticMultiselectionEditor +, multiselectionEditor +, fileEditor +, otherEditor +) where + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.ModelView as New +import Control.Monad +import Data.IORef +import Data.List +import Data.Maybe +import System.FilePath.Posix + +import IDE.Framework.Parameters +import IDE.Framework.EditorBasics +import IDE.Framework.MakeEditor +import IDE.Core.Exception + +-- ------------------------------------------------------------ +-- * Simple Editors +-- ------------------------------------------------------------ + +instance ContainerClass Widget +instance BinClass Widget +instance ButtonClass Widget + +-- +-- | Editor for a boolean value in the form of a check button +-- +boolEditor :: Editor Bool +boolEditor parameters = do + coreRef <- newIORef Nothing + notifier <- emptyNotifier + declareEvent Clicked (\w h -> w `onClicked` do h (Event True); return ()) notifier + declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier + mkEditor + (\widget bool -> do + core <- readIORef coreRef + case core of + Nothing -> do + button <- checkButtonNewWithLabel (getParameter paraName parameters) + containerAdd widget button + toggleButtonSetActive button bool + activateEvent (castToWidget button) Clicked notifier + activateEvent (castToWidget button) FocusOut notifier + writeIORef coreRef (Just button) + Just button -> toggleButtonSetActive button bool) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just button -> do + r <- toggleButtonGetActive button + return (Just r)) + (mkNotifier notifier) + (paraName <<<- (ParaName "") $ parameters) + +-- +-- | Editor for a boolean value in the form of two radio buttons +-- +boolEditor2 :: String -> Editor Bool +boolEditor2 label2 parameters = do + coreRef <- newIORef Nothing + notifier <- emptyNotifier + declareEvent Clicked (\w h -> w `onClicked` do h (Event True); return ()) notifier + declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier + mkEditor + (\widget bool -> do + core <- readIORef coreRef + case core of + Nothing -> do + box <- vBoxNew True 2 + radio1 <- radioButtonNewWithLabel (getParameter paraName parameters) + radio2 <- radioButtonNewWithLabelFromWidget radio1 label2 + boxPackStart box radio1 PackGrow 2 + boxPackStart box radio2 PackGrow 2 + containerAdd widget box + if bool + then do + toggleButtonSetActive radio1 True + else do + toggleButtonSetActive radio2 True + activateEvent (castToWidget radio1) Clicked notifier + activateEvent (castToWidget radio1) FocusOut notifier + writeIORef coreRef (Just (radio1,radio2)) + Just (radio1,radio2) -> + if bool + then do + toggleButtonSetActive radio1 True + else do + toggleButtonSetActive radio2 True) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just (radio1,radio2) -> do + r <- toggleButtonGetActive radio1 + return (Just r)) + (mkNotifier notifier) + (paraName <<<- (ParaName "") $ parameters) + +-- +-- | Editor for a string in the form of a text entry +-- +stringEditor :: Editor String +stringEditor parameters = do + coreRef <- newIORef Nothing + notifier <- emptyNotifier + declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier + mkEditor + (\widget string -> do + core <- readIORef coreRef + case core of + Nothing -> do + entry <- entryNew + activateEvent (castToWidget entry) FocusOut notifier + containerAdd widget entry + entrySetText entry string + writeIORef coreRef (Just entry) + Just entry -> entrySetText entry string) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just entry -> do + r <- entryGetText entry + return (Just r)) + (mkNotifier notifier) + parameters + +-- +-- | Editor for a multiline string in the form of a multiline text entry +-- +multilineStringEditor :: Editor String +multilineStringEditor parameters = do + coreRef <- newIORef Nothing + notifier <- emptyNotifier + declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier + declareEvent ButtonRelease (\w h -> w `onButtonRelease` h) notifier + mkEditor + (\widget string -> do + core <- readIORef coreRef + case core of + Nothing -> do + aTextView <- textViewNew + aScrolledWindow <- scrolledWindowNew Nothing Nothing + scrolledWindowSetPolicy aScrolledWindow PolicyAutomatic PolicyAutomatic + containerAdd aScrolledWindow aTextView + containerAdd widget aScrolledWindow + activateEvent (castToWidget aTextView) FocusOut notifier + activateEvent (castToWidget aTextView) ButtonRelease notifier + buffer <- textViewGetBuffer aTextView + textBufferSetText buffer string + writeIORef coreRef (Just (aScrolledWindow,aTextView)) + Just (aScrolledWindow,aTextView) -> do + buffer <- textViewGetBuffer aTextView + textBufferSetText buffer string) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just (aScrolledWindow, aTextView) -> do + buffer <- textViewGetBuffer aTextView + start <- textBufferGetStartIter buffer + end <- textBufferGetEndIter buffer + r <- textBufferGetText buffer start end False + return (Just r)) + (mkNotifier notifier) + parameters + +-- +-- | Editor for an integer in the form of a spin entry +-- +intEditor :: (Double,Double,Double) -> Editor Int +intEditor (min, max, step) parameters = do + coreRef <- newIORef Nothing + notifier <- emptyNotifier + declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier + mkEditor + (\widget v -> do + core <- readIORef coreRef + case core of + Nothing -> do + spin <- spinButtonNewWithRange min max step + activateEvent (castToWidget spin) FocusOut notifier + containerAdd widget spin + spinButtonSetValue spin (fromIntegral v) + writeIORef coreRef (Just spin) + Just spin -> spinButtonSetValue spin (fromIntegral v)) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just spin -> do + newNum <- spinButtonGetValue spin + return (Just (truncate newNum))) + (mkNotifier notifier) + parameters + +-- +-- | Editor for for any value which is an instance of Read and Show in the form of a +-- | text entry +genericEditor :: (Show beta, Read beta) => Editor beta +genericEditor parameters = do + (wid,inj,ext,notif) <- stringEditor parameters + let ginj v = inj (show v) + let gext = do + s <- ext + case s of + Nothing -> return Nothing + Just s -> + let l = read s in + if null l then + return Nothing + else return (Just (head l)) + return (wid,ginj,gext,notif) + +#ifdef False +-- +-- | Editor for the selection of an element from a static list of elements in the +-- | form of a combo box +staticSelectionEditor :: (Show beta, Eq beta) => [beta] -> Editor beta +staticSelectionEditor list parameters = do + coreRef <- newIORef Nothing + notifier <- emptyNotifier + declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier + mkEditor + (\widget obj -> do + core <- readIORef coreRef + case core of + Nothing -> do + (combo,_) <- New.comboBoxNewText show list + activateEvent (castToWidget combo) FocusOut notifier + New.comboBoxSetActive combo 1 + containerAdd widget combo + let ind = elemIndex obj list + case ind of + Just i -> New.comboBoxSetActive combo i + Nothing -> return () + writeIORef coreRef (Just combo) + Just combo -> do + let ind = elemIndex obj list + case ind of + Just i -> New.comboBoxSetActive combo i + Nothing -> return ()) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just combo -> do + ind <- New.comboBoxGetActive combo + case ind of + i | i >= 0 -> return (Just (list !! i)) + otherwise -> return Nothing) + (mkNotifier notifier) + parameters + +#else +staticSelectionEditor :: (Show beta, Eq beta) => [beta] -> Editor beta +staticSelectionEditor list parameters = do + coreRef <- newIORef Nothing + notifier <- emptyNotifier + declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier + mkEditor + (\widget obj -> do + core <- readIORef coreRef + case core of + Nothing -> do + combo <- New.comboBoxNewText + activateEvent (castToWidget combo) FocusOut notifier + New.comboBoxSetActive combo 1 + containerAdd widget combo + mapM_ (\t -> New.comboBoxAppendText combo (show t)) list + let ind = elemIndex obj list + case ind of + Just i -> New.comboBoxSetActive combo i + Nothing -> return () + writeIORef coreRef (Just combo) + Just combo -> do + let ind = elemIndex obj list + case ind of + Just i -> New.comboBoxSetActive combo i + Nothing -> return ()) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just combo -> do + mbInd <- New.comboBoxGetActive combo + case mbInd of + Just i -> return (Just (list !! i)) + otherwise -> return Nothing) + (mkNotifier notifier) + parameters +#endif + + +-- +-- | Editor for the selection of some elements from a static list of elements in the +-- | form of a list box + +multiselectionEditor :: (Show beta, Eq beta) => Editor [beta] +multiselectionEditor parameters = do + coreRef <- newIORef Nothing + notifier <- emptyNotifier + declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier + mkEditor + (\widget objs -> do + core <- readIORef coreRef + case core of + Nothing -> do + listStore <- New.listStoreNew ([]:: [alpha]) + listView <- New.treeViewNewWithModel listStore + activateEvent (castToWidget listView) FocusOut notifier + sel <- New.treeViewGetSelection listView + New.treeSelectionSetMode sel SelectionMultiple + renderer <- New.cellRendererTextNew + col <- New.treeViewColumnNew + New.treeViewAppendColumn listView col + New.cellLayoutPackStart col renderer True + New.cellLayoutSetAttributes col renderer listStore $ \row -> [ New.cellText := show row ] + New.treeViewSetHeadersVisible listView False + New.listStoreClear listStore + mapM_ (New.listStoreAppend listStore) objs + containerAdd widget listView + New.treeSelectionUnselectAll sel + --let inds = catMaybes $map (\obj -> elemIndex obj list) objs + --mapM_ (\i -> New.treeSelectionSelectPath sel [i]) inds + writeIORef coreRef (Just (listView,listStore)) + Just (listView,listStore) -> do + New.listStoreClear listStore + mapM_ (New.listStoreAppend listStore) objs) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just (listView,listStore) -> do + sel <- New.treeViewGetSelection listView + treePath <- New.treeSelectionGetSelectedRows sel + values <- mapM (\[i] -> listStoreGetValue listStore i) treePath + return (Just values)) + (mkNotifier notifier) + parameters + +-- +-- | Editor for the selection of some elements from a static list of elements in the +-- | form of a list box + +staticMultiselectionEditor :: (Show beta, Eq beta) => [beta] -> Editor [beta] +staticMultiselectionEditor list parameters = do + coreRef <- newIORef Nothing + notifier <- emptyNotifier + declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier + mkEditor + (\widget objs -> do + core <- readIORef coreRef + case core of + Nothing -> do + listStore <- New.listStoreNew ([]:: [alpha]) + listView <- New.treeViewNewWithModel listStore + activateEvent (castToWidget listView) FocusOut notifier + sel <- New.treeViewGetSelection listView + New.treeSelectionSetMode sel SelectionMultiple + renderer <- New.cellRendererTextNew + col <- New.treeViewColumnNew + New.treeViewAppendColumn listView col + New.cellLayoutPackStart col renderer True + New.cellLayoutSetAttributes col renderer listStore $ \row -> [ New.cellText := show row ] + New.treeViewSetHeadersVisible listView False + New.listStoreClear listStore + mapM_ (New.listStoreAppend listStore) list + containerAdd widget listView + New.treeSelectionUnselectAll sel + let inds = catMaybes $map (\obj -> elemIndex obj list) objs + mapM_ (\i -> New.treeSelectionSelectPath sel [i]) inds + writeIORef coreRef (Just listView) + Just listView -> do + sel <- New.treeViewGetSelection listView + New.treeSelectionUnselectAll sel + let inds = catMaybes $map (\obj -> elemIndex obj list) objs + mapM_ (\i -> New.treeSelectionSelectPath sel [i]) inds) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just listView -> do + sel <- New.treeViewGetSelection listView + treePath <- New.treeSelectionGetSelectedRows sel + return (Just (map (\[i] -> list !! i) treePath))) + (mkNotifier notifier) + parameters + +-- +-- | Editor for the selection of a file path in the form of a text entry and a button, +-- | which opens a gtk file chooser +fileEditor :: Maybe FilePath -> FileChooserAction -> String -> Editor FilePath +fileEditor mbFilePath action buttonName parameters = do + coreRef <- newIORef Nothing + notifier <- emptyNotifier + declareEvent Clicked + (\widget handler -> do widget `onClicked` do + handler (Event True) + return ()) notifier + declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier + mkEditor + (\widget filePath -> do + core <- readIORef coreRef + case core of + Nothing -> do + button <- buttonNewWithLabel buttonName + entry <- entryNew + set entry [ entryEditable := False ] + activateEvent (castToWidget button) Clicked notifier + (mkNotifier notifier) Clicked (Left (buttonHandler entry)) + box <- case getParameter paraDirection parameters of + Horizontal -> do + r <- hBoxNew False 1 + return (castToBox r) + Vertical -> do + r <- vBoxNew False 1 + return (castToBox r) + activateEvent (castToWidget button) FocusOut notifier + boxPackStart box entry PackGrow 0 + boxPackEnd box button PackNatural 0 + containerAdd widget box + entrySetText entry filePath + writeIORef coreRef (Just entry) + Just entry -> entrySetText entry filePath) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just entry -> do + str <- entryGetText entry + return (Just str)) + (mkNotifier notifier) + parameters + where + buttonHandler entry = (\ e -> do + mbFileName <- do + dialog <- fileChooserDialogNew + (Just $ "Select File") + Nothing + action + [("gtk-cancel" + ,ResponseCancel) + ,("gtk-open" + ,ResponseAccept)] + widgetShow dialog + response <- dialogRun dialog + case response of + ResponseAccept -> do + f <- fileChooserGetFilename dialog + widgetDestroy dialog + return f + ResponseCancel -> do + widgetDestroy dialog + return Nothing + ResponseDeleteEvent-> do + widgetDestroy dialog + return Nothing + _ -> return Nothing + case mbFileName of + Nothing -> return True + Just fn -> do + let relative = case mbFilePath of + Nothing -> fn + Just rel -> makeRelative rel fn + entrySetText entry relative + return True) + +-- +-- | Editor for a font selection +-- +fontEditor :: Editor (Maybe String) +fontEditor parameters = do + coreRef <- newIORef Nothing + notifier <- emptyNotifier + declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier + mkEditor + (\widget mbValue -> do + core <- readIORef coreRef + case core of + Nothing -> do + fs <- fontButtonNew + activateEvent (castToWidget fs) FocusOut notifier + containerAdd widget fs + case mbValue of + Nothing -> return True + Just s -> fontButtonSetFontName fs s + writeIORef coreRef (Just fs) + Just fs -> case mbValue of + Nothing -> return () + Just s -> do + fontButtonSetFontName fs s + return ()) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just fs -> do + f <- fontButtonGetFontName fs + return (Just (Just f))) + (mkNotifier notifier) + parameters + +-- +-- | An editor, which opens another editor +-- You have to inject a value before the button can be clicked. +-- +otherEditor :: (alpha -> String -> IO (Maybe alpha)) -> Editor alpha +otherEditor func parameters = do + coreRef <- newIORef Nothing + notifier <- emptyNotifier + declareEvent Clicked (\w h -> w `onClicked` do h (Event True); return ()) notifier + declareEvent FocusIn (\w h -> w `onFocusIn` do h) notifier + declareEvent FocusOut (\w h -> w `onFocusOut` do h) notifier + mkEditor + (\widget val -> do + core <- readIORef coreRef + case core of + Nothing -> do + button <- buttonNewWithLabel (getParameter paraName parameters) + containerAdd widget button + activateEvent (castToWidget button) Clicked notifier + activateEvent (castToWidget button) FocusIn notifier + activateEvent (castToWidget button) FocusOut notifier + (mkNotifier notifier) Clicked (Left (buttonHandler coreRef)) + writeIORef coreRef (Just (button,val)) + Just (button, oldval) -> writeIORef coreRef (Just (button, val))) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just (_,val) -> return (Just val)) + (mkNotifier notifier) + (paraName <<<- (ParaName "") $ parameters) + where + buttonHandler coreRef = (\ e -> do + core <- readIORef coreRef + case core of + Nothing -> throwIDE "You have to inject a value before the button can be clicked" + Just (b,val) -> do + res <- func val (getParameter paraName parameters) + case res of + Nothing -> return True + Just nval -> do + writeIORef coreRef (Just (b, nval)) + return True) diff --git a/src/IDE/Framework/ViewFrame.hs b/src/IDE/Framework/ViewFrame.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Framework/ViewFrame.hs @@ -0,0 +1,697 @@ +----------------------------------------------------------------------------- +-- +-- Module : IDE.Framework.ViewFrame +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- +-- | Splittable panes containing notebooks with any widgets +-- +--------------------------------------------------------------------------------- + +module IDE.Framework.ViewFrame ( + removePaneAdmin +, addPaneAdmin +, notebookInsertOrdered + +-- * Convenience methods for accesing Pane state +, posTypeToPaneDirection +, paneDirectionToPosType +, paneFromName +, mbPaneFromName +, guiPropertiesFromName + +-- * View Actions +, viewMove +, viewSplitHorizontal +, viewSplitVertical +, viewSplit +, viewSplit' +, viewCollapse +, viewTabsPos +, viewSwitchTabs + +-- * View Queries +, getStandardPanePath +, getActivePanePath +, getActivePanePathOrStandard +, figureOutPaneName +, getNotebook +, getPaned +, getActiveNotebook +, getPane +, getPanes + +-- * View Actions +, bringPaneToFront +, newNotebook +, activatePane +, deactivatePane +, deactivatePaneIfActive + +-- * Accessing GUI elements +, widgetFromPath +, getCandyState +, setCandyState + +, getSBSpecialKeys +, getSBActivePane +, getSBActivePackage +, getSBErrors +, getStatusbarIO +, getStatusbarLC + +) where + +import Graphics.UI.Gtk hiding (afterToggleOverwrite,onToggleOverwrite) +import Control.Monad.Reader +import qualified Data.Map as Map +import Data.Map (Map) +import Data.List +import Data.Maybe +import GHC.Exception(evaluate,catch) + +import IDE.Core.State +import IDE.Core.Types +import IDE.Core.Panes +import IDE.Framework.Parameters + +removePaneAdmin :: (CastablePane alpha,RecoverablePane alpha beta) => alpha -> IDEAction +removePaneAdmin pane = do + panes' <- readIDE panes + paneMap' <- readIDE paneMap + let newPanes = Map.delete (paneName pane) panes' + let newPaneMap = Map.delete (paneName pane) paneMap' + modifyIDE_ (\ide -> return (ide{panes = newPanes, paneMap = newPaneMap})) + +addPaneAdmin :: (CastablePane alpha,RecoverablePane alpha beta) => alpha -> Connections -> PanePath -> IDEAction +addPaneAdmin pane conn pp = do + panes' <- readIDE panes + paneMap' <- readIDE paneMap + let newPaneMap = Map.insert (paneName pane) (pp, conn) paneMap' + let newPanes = Map.insert (paneName pane) (PaneC pane) panes' + modifyIDE_ (\ide -> return (ide{panes = newPanes, + paneMap = newPaneMap})) + + +notebookInsertOrdered :: (NotebookClass self, WidgetClass child) + => self + -> child -- child - the Widget to use as the contents of the page. + -> String -- tabLabel - the label for the page + -> IO () +notebookInsertOrdered nb widget label = do + numPages <- notebookGetNPages nb + mbWidgets <- mapM (notebookGetNthPage nb) [0 .. (numPages-1)] + widgets <- catch (evaluate (map fromJust mbWidgets)) + (\e -> throwIDE "ViewFrame.notebookInsertOrdered: no widget") + mbLabels <- mapM (notebookGetTabLabelText nb) widgets + labels <- catch (evaluate (map fromJust mbLabels)) + (\e -> throwIDE "ViewFrame.notebookInsertOrdered: no label") + let pos = case findIndex (\s -> s > label) labels of + Just i -> i + Nothing -> -1 + realPos <- notebookInsertPage nb widget label pos + notebookSetCurrentPage nb realPos +getPane :: CastablePane alpha => Casting alpha -> IDEM (Maybe alpha) +getPane casting = do + selectedPanes <- getPanes casting + if null selectedPanes || length selectedPanes > 1 + then return Nothing + else (return (Just $head selectedPanes)) + +getPanes :: CastablePane alpha => Casting alpha -> IDEM ([alpha]) +getPanes casting = do + panes' <- readIDE panes + return (catMaybes $ map (downCast casting) $ Map.elems panes') + +-- | Constructs a unique pane name, which is an index and a string +figureOutPaneName :: Pane alpha => Map String alpha -> String -> Int -> (Int,String) +figureOutPaneName bufs bn ind = + let ind = foldr (\buf ind -> + if primPaneName buf == bn + then max ind ((getAddedIndex buf) + 1) + else ind) + 0 (Map.elems bufs) + in if ind == 0 + then (0,bn) + else (ind,bn ++ "(" ++ show ind ++ ")") + +paneFromName :: PaneName -> IDEM IDEPane +paneFromName pn = do + mbPane <- mbPaneFromName pn + case mbPane of + Just p -> return p + Nothing -> throwIDE $"Cant't find pane from unique name " ++ pn + +mbPaneFromName :: PaneName -> IDEM (Maybe IDEPane) +mbPaneFromName pn = do + panes <- readIDE panes + return (Map.lookup pn panes) + +-- | +guiPropertiesFromName :: PaneName -> IDEM (PanePath, Connections) +guiPropertiesFromName pn = do + paneMap <- readIDE paneMap + case Map.lookup pn paneMap of + Just it -> return it + otherwise -> throwIDE $"Cant't find guiProperties from unique name " ++ pn + +posTypeToPaneDirection PosLeft = LeftP +posTypeToPaneDirection PosRight = RightP +posTypeToPaneDirection PosTop = TopP +posTypeToPaneDirection PosBottom = BottomP + +paneDirectionToPosType LeftP = PosLeft +paneDirectionToPosType RightP = PosRight +paneDirectionToPosType TopP = PosTop +paneDirectionToPosType BottomP = PosBottom + +activatePane :: Pane alpha => alpha -> Connections -> IDEAction +activatePane pane conn = do + deactivatePane + sb <- getSBActivePane + lift $statusbarPop sb 1 + lift $statusbarPush sb 1 (paneName pane) + modifyIDE_ $ \ide -> do + bringPaneToFront pane + return (ide{activePane = Just (paneName pane,conn)}) + +deactivatePane :: IDEAction +deactivatePane = do + sb <- getSBActivePane + lift $statusbarPop sb 1 + lift $statusbarPush sb 1 "" + mbAP <- readIDE activePane + case mbAP of + Just (_,BufConnections signals signals2 signals3) -> lift $do + mapM_ signalDisconnect signals + mapM_ signalDisconnect signals2 + mapM_ signalDisconnect signals3 + Nothing -> return () + modifyIDE_ $ \ide -> do + return (ide{activePane = Nothing}) + +deactivatePaneIfActive :: Pane alpha => alpha -> IDEAction +deactivatePaneIfActive pane = do + mbActive <- readIDE activePane + case mbActive of + Nothing -> return () + Just (n,_) -> if n == paneName pane + then deactivatePane + else return () +-- +-- | Toggle the tabs of the current notebook +-- +viewSwitchTabs :: IDEAction +viewSwitchTabs = do + mbNb <- getActiveNotebook + case mbNb of + Nothing -> return () + Just nb -> lift $do + b <- notebookGetShowTabs nb + notebookSetShowTabs nb (not b) + +-- +-- | Sets the tab position in the current notebook +-- +viewTabsPos :: PositionType -> IDEAction +viewTabsPos pos = do + mbNb <- getActiveNotebook + case mbNb of + Nothing -> return () + Just nb -> lift $notebookSetTabPos nb pos + +-- +-- | Split the currently active pane in horizontal direction +-- +viewSplitHorizontal :: IDEAction +viewSplitHorizontal = viewSplit Horizontal + +-- +-- | Split the currently active pane in vertical direction +-- +viewSplitVertical :: IDEAction +viewSplitVertical = viewSplit Vertical + +-- +-- | The active view can be split in two (horizontal or vertical) +-- +viewSplit :: Direction -> IDEAction +viewSplit dir = do + mbPanePath <- getActivePanePath + case mbPanePath of + Nothing -> return () + Just panePath -> viewSplit' panePath dir + +viewSplit' :: PanePath -> Direction -> IDEAction +viewSplit' panePath dir = do + activeNotebook <- getNotebook panePath + mbPD <- lift $ do + mbParent <- widgetGetParent activeNotebook + case mbParent of + Nothing -> return Nothing + Just parent -> do + --trace ("Pane path " ++ show panePath) return () + newpane <- case dir of + Horizontal -> do h <- vPanedNew + return (castToPaned h) + Vertical -> do v <- hPanedNew + return (castToPaned v) + let (name,altname,paneDir) = case dir of + Horizontal -> ("top","bottom",TopP) + Vertical -> ("left","right",LeftP) + rName <- widgetGetName activeNotebook + widgetSetName newpane rName + nb <- newNotebook + widgetSetName nb altname + panedPack2 newpane nb True True + containerRemove (castToContainer parent) activeNotebook + widgetSetName activeNotebook name + panedPack1 newpane activeNotebook True True + if not (null panePath) + then + if (last panePath == TopP || last panePath == LeftP) + then panedPack1 (castToPaned parent) newpane True True + else panedPack2 (castToPaned parent) newpane True True + else do + boxPackStart (castToBox parent) newpane PackGrow 0 + boxReorderChild (castToVBox parent) newpane 2 + widgetShowAll newpane + widgetGrabFocus activeNotebook + return (Just (paneDir,dir)) + case mbPD of + Just (paneDir,dir) -> do + let toPane = panePath ++ [paneDir] + adjustPane panePath toPane + adjustLayoutForSplit dir panePath + Nothing -> return () + +-- +-- | Two notebooks can be collapsed to one +-- +viewCollapse :: IDEAction +viewCollapse = do + mbPanePath <- getActivePanePath + case mbPanePath of + Nothing -> return () + Just panePath -> do + viewCollapse' panePath + +viewCollapse' :: PanePath -> IDEAction +viewCollapse' panePath = do + layout1 <- readIDE layout + let newPanePath = reverse $tail $reverse panePath + let mbOtherSidePath = otherSide panePath + case mbOtherSidePath of + Nothing -> ideMessage Normal "Can't collapse top level" + Just otherSidePath -> + let sp1 = getSubpath panePath layout1 + sp2 = getSubpath otherSidePath layout1 + in do + case sp1 of + Nothing -> return () + Just sp -> viewCollapse' sp + case sp2 of + Nothing -> return () + Just sp -> viewCollapse' sp + paneMap <- readIDE paneMap + activeNotebook <- getNotebook panePath + let paneNamesToMove = map (\(w,(p,_)) -> w) + $filter (\(w,(p,_)) -> p == otherSidePath) + $Map.toList paneMap + panesToMove <- mapM paneFromName paneNamesToMove + mapM_ (move panePath) panesToMove + lift $ do + mbParent <- widgetGetParent activeNotebook + case mbParent of + Nothing -> throwIDE "collapse: no parent" + Just parent -> do + mbGrandparent <- widgetGetParent parent + case mbGrandparent of + Nothing -> throwIDE "collapse: no grandparent" + Just grandparent -> do + containerRemove (castToContainer grandparent) parent + containerRemove (castToContainer parent) activeNotebook + if length panePath > 1 + then do + let dir = last newPanePath + if (dir == TopP || dir == LeftP) + then panedPack1 (castToPaned grandparent) + activeNotebook True True + else panedPack2 (castToPaned grandparent) + activeNotebook True True + widgetSetName activeNotebook $paneDirectionToWidgetName dir + else do + boxPackStart (castToVBox grandparent) activeNotebook PackGrow 0 + boxReorderChild (castToVBox grandparent) activeNotebook 2 + widgetSetName activeNotebook "root" + adjustLayoutForCollapse newPanePath + adjustPane panePath newPanePath + --adjustPane otherSidePath newPanePath + +-- +-- | Moves the given Pane to the given path +-- +move :: PanePath -> IDEPane -> IDEAction +move toPane idew = do + paneMap <- readIDE paneMap + let child = getTopWidget idew + (fromPane,cid) <- guiPropertiesFromName (paneName idew) + fromNB <- getNotebook fromPane + toNB <- getNotebook toPane + lift $ do + mbNum <- notebookPageNum fromNB child + case mbNum of + Nothing -> return () + Just pn -> do + mbText <- notebookGetTabLabelText fromNB child + case mbText of + Nothing -> return () + Just text -> do + notebookRemovePage fromNB pn + notebookInsertOrdered toNB child text + let paneMap1 = Map.delete (paneName idew) paneMap + let newPaneMap = Map.insert (paneName idew) (toPane,cid) paneMap1 + modifyIDE_ (\ide -> return (ide{paneMap = newPaneMap})) + +-- +-- | Moves the activePane in the given direction, if possible +-- | If their are many possibilities choose the leftmost and topmost +-- +viewMove :: PaneDirection -> IDEAction +viewMove direction = do + mbPane <- readIDE activePane + case mbPane of + Nothing -> do + ideMessage Normal "no active pane" + return () + Just (paneName,_) -> do + pane <- paneFromName paneName + mbPanePath <- getActivePanePath + case mbPanePath of + Nothing -> do + ideMessage Normal "no active pane path" + return () + Just panePath -> do + layout <- readIDE layout + case findMoveTarget panePath layout direction of + Nothing -> do + ideMessage Normal "no target found" + return () + Just moveTo -> move moveTo pane + +-- +-- | Find the target for a move +-- +findMoveTarget :: PanePath -> PaneLayout -> PaneDirection -> Maybe PanePath +findMoveTarget panePath layout direction= + let reversedPath = reverse panePath + oppositeDir = otherDirection direction + cutPath = dropWhile (\d -> d /= oppositeDir) reversedPath + in if null cutPath + then Nothing + else let basePath = reverse (direction : tail cutPath) + layoutP = layoutFromPath basePath layout + in Just $basePath ++ findAppropriate layoutP oppositeDir + +findAppropriate :: PaneLayout -> PaneDirection -> PanePath +findAppropriate (TerminalP _ _) _ = [] +findAppropriate (HorizontalP t b _) LeftP = TopP : findAppropriate t LeftP +findAppropriate (HorizontalP t b _) RightP = TopP : findAppropriate t RightP +findAppropriate (HorizontalP t b _) BottomP = BottomP : findAppropriate b BottomP +findAppropriate (HorizontalP t b _) TopP = TopP : findAppropriate b TopP +findAppropriate (VerticalP l r _) LeftP = LeftP : findAppropriate l LeftP +findAppropriate (VerticalP l r _) RightP = RightP : findAppropriate r RightP +findAppropriate (VerticalP l r _) BottomP = LeftP : findAppropriate l BottomP +findAppropriate (VerticalP l r _) TopP = LeftP : findAppropriate l TopP + +-- +-- | Bring the pane to the front position in its notebook +-- +bringPaneToFront :: Pane alpha => alpha -> IO () +bringPaneToFront pane = do + let tv = getTopWidget pane + mbParent <- widgetGetParent tv + case mbParent of + Just parent -> do + let nb = castToNotebook parent + n <- notebookGetNPages nb + r <- filterM (\i -> do + mbp <- notebookGetNthPage nb i + case mbp of + Nothing -> return False + Just p -> do + mbs <- notebookGetTabLabelText nb p + case mbs of + Nothing -> return False + Just s -> return (s == paneName pane)) + [0..(n-1)] + case r of + [i] -> notebookSetCurrentPage nb i + otherwise -> return () + Nothing -> return () + +-- +-- | Get a concrete panePath from a standard path. +-- Standard path is for example left top. +-- +getStandardPanePath :: StandardPath -> PaneLayout -> PanePath +getStandardPanePath sp pl = reverse $ getStandard' sp pl [] + where + getStandard' _ (TerminalP _ _) p = p + getStandard' LeftTop (VerticalP l r _) p = getStandard' LeftTop l (LeftP:p) + getStandard' LeftBottom (VerticalP l r _) p = getStandard' LeftBottom l (LeftP:p) + getStandard' RightTop (VerticalP l r _) p = getStandard' RightTop r (RightP:p) + getStandard' RightBottom (VerticalP l r _) p = getStandard' RightBottom r (RightP:p) + getStandard' LeftTop (HorizontalP t b _) p = getStandard' LeftTop t (TopP:p) + getStandard' LeftBottom (HorizontalP t b _) p = getStandard' LeftBottom b (BottomP:p) + getStandard' RightTop (HorizontalP t b _) p = getStandard' RightTop t (TopP:p) + getStandard' RightBottom (HorizontalP t b _) p = getStandard' RightBottom b (BottomP:p) + +-- +-- | Construct a new notebook +-- +newNotebook :: IO Notebook +newNotebook = do + nb <- notebookNew + notebookSetTabPos nb PosTop + notebookSetShowTabs nb True + notebookSetScrollable nb True + notebookSetPopup nb True + return nb + + +-- +-- | Get another pane path which points to the other side at the same level +-- +otherSide :: PanePath -> Maybe PanePath +otherSide [] = Nothing +otherSide p = let rp = reverse p + ae = otherDirection $head rp + in Just (reverse $ae : tail rp) + +-- +-- | Get the opposite direction of a pane direction +-- +otherDirection :: PaneDirection -> PaneDirection +otherDirection LeftP = RightP +otherDirection RightP = LeftP +otherDirection TopP = BottomP +otherDirection BottomP = TopP + +-- +-- | Get the layout at the given pane path +-- +layoutFromPath :: PanePath -> PaneLayout -> PaneLayout +layoutFromPath [] l = l +layoutFromPath (TopP:r) (HorizontalP t _ _) = layoutFromPath r t +layoutFromPath (BottomP:r) (HorizontalP _ b _) = layoutFromPath r b +layoutFromPath (LeftP:r) (VerticalP l _ _) = layoutFromPath r l +layoutFromPath (RightP:r) (VerticalP _ ri _) = layoutFromPath r ri +layoutFromPath pp l = error + $"inconsistent layout " ++ show pp ++ " " ++ show l + + +getNotebookOrPaned :: PanePath -> (Widget -> beta) -> IDEM beta +getNotebookOrPaned p cf = (widgetGet $["topBox","root"] ++ map paneDirectionToWidgetName p) cf + +-- +-- | Get the notebook widget for the given pane path +-- +getNotebook :: PanePath -> IDEM Notebook +getNotebook p = getNotebookOrPaned p castToNotebook + +-- +-- | Get the (gtk) Paned widget for a given path +-- +getPaned :: PanePath -> IDEM Paned +getPaned p = getNotebookOrPaned p castToPaned + +-- +-- | Get the path to the active pane +-- +getActivePanePath :: IDEM (Maybe PanePath) +getActivePanePath = do + mbPane <- readIDE activePane + case mbPane of + Nothing -> return Nothing + Just (paneName,_) -> do + (pp,_) <- guiPropertiesFromName paneName + return (Just (pp)) + +getActivePanePathOrStandard :: StandardPath -> IDEM (PanePath) +getActivePanePathOrStandard sp = do + mbApp <- getActivePanePath + case mbApp of + Just app -> return app + Nothing -> do + layout <- readIDE layout + return (getStandardPanePath sp layout) + + +-- +-- | Get the active notebook +-- +getActiveNotebook :: IDEM (Maybe Notebook) +getActiveNotebook = do + mbPanePath <- getActivePanePath + case mbPanePath of + Just panePath -> do + nb <- getNotebook panePath + return (Just nb) + Nothing -> return Nothing + + +-- +-- | Translates a pane direction to the widget name +-- +paneDirectionToWidgetName :: PaneDirection -> String +paneDirectionToWidgetName TopP = "top" +paneDirectionToWidgetName BottomP = "bottom" +paneDirectionToWidgetName LeftP = "left" +paneDirectionToWidgetName RightP = "right" + +-- +-- | Changes a pane path in the pane map +-- +adjustPane :: PanePath -> PanePath -> IDEAction +adjustPane fromPane toPane = do + paneMap <- readIDE paneMap + let newMap = Map.map (\(pp,other) -> do + if pp == fromPane + then (toPane,other) + else (pp,other)) paneMap + modifyIDE_ $ \ide -> return (ide{paneMap = newMap}) + +-- +-- | Changes the layout for a split +-- +adjustLayoutForSplit :: Direction -> PanePath -> IDEAction +adjustLayoutForSplit dir path = do + layout <- readIDE layout + let newTerm = case dir of + Horizontal -> HorizontalP (TerminalP Nothing 0) (TerminalP Nothing 0) 0 + Vertical -> VerticalP (TerminalP Nothing 0) (TerminalP Nothing 0) 0 + let newLayout = adjust path layout newTerm + modifyIDE_ $ \ide -> return (ide{layout = newLayout}) + +-- +-- | Changes the layout for a collapse (HorizontalP TerminalP (VerticalP (HorizontalP TerminalP TerminalP) TerminalP)) + +-- +adjustLayoutForCollapse :: PanePath -> IDEAction +adjustLayoutForCollapse path = do + layout <- readIDE layout + let newLayout = adjust path layout (TerminalP Nothing 0) + modifyIDE_ $ \ide -> return (ide{layout = newLayout}) + +getSubpath :: PanePath -> PaneLayout -> Maybe PanePath +getSubpath path layout = + case layoutFromPath path layout of + TerminalP _ _ -> Nothing + HorizontalP _ _ _ -> Just (path ++ [TopP]) + VerticalP _ _ _ -> Just (path ++ [LeftP]) + +-- +-- | Changes the layout by replacing element at pane path with replace +-- +adjust :: PanePath -> PaneLayout -> PaneLayout -> PaneLayout +adjust pp layout replace = adjust' pp layout + where + adjust' [] _ = replace + adjust' (TopP:r) (HorizontalP tp bp _) = HorizontalP (adjust' r tp) bp 0 + adjust' (BottomP:r) (HorizontalP tp bp _) = HorizontalP tp (adjust' r bp) 0 + adjust' (LeftP:r) (VerticalP lp rp _) = VerticalP (adjust' r lp) rp 0 + adjust' (RightP:r) (VerticalP lp rp _) = VerticalP lp (adjust' r rp) 0 + adjust' p l = throwIDE $"inconsistent layout " ++ show p ++ " " ++ show l + +-- +-- | Get the widget from a list of strings +-- +widgetFromPath :: Widget -> [String] -> IO (Widget) +widgetFromPath w [] = return w +widgetFromPath w (h:t) = do + children <- containerGetChildren (castToContainer w) + names <- mapM widgetGetName children + let mbiInd = findIndex (== h) names + case mbiInd of + Nothing -> throwIDE $"Cant't find widget path " ++ show (h:t) + Just ind -> widgetFromPath (children !! ind) t + + +widgetGet :: [String] -> (Widget -> b) -> IDEM (b) +widgetGet strL cf = do + w <- readIDE window + r <- lift $widgetFromPath (castToWidget w) strL + return (cf r) + +widgetGetRel :: Widget -> [String] -> (Widget -> b) -> IO (b) +widgetGetRel w sl cf = do + r <- widgetFromPath w sl + return (cf r) + +getUIAction :: String -> (Action -> a) -> IDEM(a) +getUIAction str f = do + uiManager <- readIDE uiManager + lift $ do + findAction <- uiManagerGetAction uiManager str + case findAction of + Just act -> return (f act) + Nothing -> throwIDE $"getUIAction can't find action " ++ str + +--get widget elements + +getCandyState :: IDEM (Bool) +getCandyState = do + ui <- getUIAction "ui/menubar/_Edit/Source Candy" castToToggleAction + lift $toggleActionGetActive ui + +setCandyState :: Bool -> IDEAction +setCandyState b = do + ui <- getUIAction "ui/menubar/_Edit/Source Candy" castToToggleAction + lift $toggleActionSetActive ui b +-- + +getSBSpecialKeys :: IDEM (Statusbar) +getSBSpecialKeys = widgetGet ["topBox","statusBox","statusBarSpecialKeys"] castToStatusbar + +getSBActivePane :: IDEM (Statusbar) +getSBActivePane = widgetGet ["topBox","statusBox","statusBarActivePane"] castToStatusbar + +getSBActivePackage :: IDEM (Statusbar) +getSBActivePackage = widgetGet ["topBox","statusBox","statusBarActiveProject"] castToStatusbar + +getSBErrors :: IDEM (Statusbar) +getSBErrors = widgetGet ["topBox","statusBox","statusBarErrors"] castToStatusbar + +getStatusbarIO :: IDEM (Statusbar) +getStatusbarIO = widgetGet ["topBox","statusBox","statusBarInsertOverwrite"] castToStatusbar + +getStatusbarLC :: IDEM (Statusbar) +getStatusbarLC = widgetGet ["topBox","statusBox","statusBarLineColumn"] castToStatusbar + + diff --git a/src/IDE/InfoPane.hs b/src/IDE/InfoPane.hs new file mode 100644 --- /dev/null +++ b/src/IDE/InfoPane.hs @@ -0,0 +1,318 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.InfoPane +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | The GUI stuff for infos +-- +------------------------------------------------------------------------------- + +module IDE.InfoPane ( + setInfos +, setSymbol +) where + +import Graphics.UI.Gtk hiding (afterToggleOverwrite) +import Control.Monad.Reader +import System.IO +import Control.Monad +import Control.Monad.Trans +import System.IO +import Data.List +import Data.Maybe +import qualified Data.ByteString.Char8 as BS +import Data.IORef(newIORef,readIORef,writeIORef) +import qualified Data.Map as Map + +import IDE.Core.State +import IDE.Framework.ViewFrame +import IDE.Framework.MakeEditor +import IDE.Framework.SimpleEditors +import IDE.Framework.Parameters +import IDE.SourceEditor +import IDE.CallersPane +import IDE.Framework.EditorBasics + +instance IDEObject IDEInfo + +instance Pane IDEInfo + where + primPaneName _ = "Info" + getAddedIndex _ = 0 + getTopWidget = castToWidget . sw + paneId b = "*Info" + makeActive pane = activatePane pane (BufConnections[][][]) + close pane = do + (panePath,_) <- guiPropertiesFromName (paneName pane) + nb <- getNotebook panePath + mbI <- lift $notebookPageNum nb (getTopWidget pane) + case mbI of + Nothing -> lift $ do + sysMessage Normal "notebook page not found: unexpected" + return () + Just i -> do + deactivatePaneIfActive pane + lift $notebookRemovePage nb i + removePaneAdmin pane + +instance RecoverablePane IDEInfo InfoState where + saveState p = do + currentIDsU <- lift $ readIORef (currentIDs p) + currentIndU <- lift $ readIORef (currentInd p) + return (Just (StateC (InfoState currentIDsU currentIndU))) + recoverState pp (InfoState currentIDsU currentIndu) = do + nb <- getNotebook pp + initInfo pp nb currentIDsU currentIndu + +idDescrDescr :: IDERef -> [FieldDescription IdentifierDescr] +idDescrDescr ideR = [ + mkField + (paraName <<<- ParaName "Symbol" + $ paraHorizontal <<<- ParaHorizontal StartHorizontal + $ emptyParams) + identifierID + (\ b a -> a{identifierID = b}) + stringEditor + , mkField + (paraName <<<- ParaName "Sort" + $ emptyParams) + idType + (\b a -> a) + (staticSelectionEditor allIdTypes) + , mkField + (paraName <<<- ParaName "Exported by" + $ paraHorizontal <<<- ParaHorizontal StopHorizontal + $ emptyParams) + (\l -> showPackModule (moduleIdID l)) + (\ b a -> a{moduleIdID = parsePackModule b}) + stringEditor + , mkField + (paraName <<<- ParaName "Type" $ emptyParams) + (BS.unpack . typeInfo) + (\b a -> a) + (typeEditor ideR) + , mkField + (paraName <<<- ParaName "Comment" $ emptyParams) + (\l -> case mbComment l of + Nothing -> "" + Just s -> BS.unpack s) + (\ b a -> case b of + "" -> a{mbComment = Nothing} + s -> a{mbComment = Just (BS.pack s)}) + multilineStringEditor] + +{-- , mkField (emptyParams + {paraName = Just "Documentation"}) + typeInfo + (\b a -> a{typeInfo = b}) + multilineStringEditor--} + +allIdTypes = [Function, Newtype, Type, AbstractData, OpenData, Foreign + , Data, Class, Instance, Constructor, Field, Method, OrphanedInstance] + +typeEditor :: IDERef -> Editor String +typeEditor ideR para = do + ed@(wid,inj,ext,notif) <- multilineStringEditor para + notif ButtonRelease $Left (\e -> showInfoHandler wid ideR) + return ed + +showInfoHandler :: Widget -> IDERef -> IO Bool +showInfoHandler wid ideR = do + mbFrame <- binGetChild (castToAlignment wid) + mbInner <- binGetChild (castToFrame (forceJust mbFrame "InfoPane>>typeEditor: Can't find child")) + mbScrolled <- binGetChild (castToAlignment (forceJust mbInner "InfoPane>>typeEditor: Can't find child2")) + mbTV <- binGetChild (castToScrolledWindow (forceJust mbScrolled "InfoPane>>typeEditor: Can't find child3")) + buf <- textViewGetBuffer (castToTextView (forceJust mbTV "InfoPane>>typeEditor: Can't find child4")) + (l,r) <- textBufferGetSelectionBounds buf + symbol <- textBufferGetText buf l r True + runReaderT (triggerEvent ideR (SelectInfo symbol)) ideR + return False + +initInfo :: PanePath -> Notebook -> [IdentifierDescr] -> Int -> IDEAction +initInfo panePath nb idDescrs index = do + when (length idDescrs > index) $ do + ideR <- ask + panes <- readIDE panes + paneMap <- readIDE paneMap + prefs <- readIDE prefs + (pane,cids) <- lift $ do + nbbox <- hBoxNew False 0 + ibox <- vBoxNew False 0 + bb <- vButtonBoxNew + buttonBoxSetLayout bb ButtonboxStart + definitionB <- buttonNewWithLabel "Source" + moduB <- buttonNewWithLabel "Selection" + usesB <- buttonNewWithLabel "Uses" + docuB <- buttonNewWithLabel "Docu" + widgetSetSensitivity docuB False + nextB <- buttonNewWithLabel "Next" + prevB <- buttonNewWithLabel "Prev" + when (length idDescrs < 2) $ widgetSetSensitivity nextB False + widgetSetSensitivity prevB False + label <- labelNew (Just ("1" ++ "/" ++ show (length idDescrs))) + boxPackStart bb definitionB PackNatural 0 + boxPackStart bb moduB PackNatural 0 + boxPackStart bb usesB PackNatural 0 + boxPackStart bb docuB PackNatural 0 + boxPackStart bb label PackNatural 0 + boxPackStart bb nextB PackNatural 0 + boxPackStart bb prevB PackNatural 0 + + resList <- mapM (\ fd -> (fieldEditor fd) (head idDescrs)) (idDescrDescr ideR) + let (widgets, setInjs, getExts, notifiers) = unzip4 resList + foldM_ (\ box (w,mbh) -> + case mbh of + Keep -> do boxPackStart box w PackGrow 0 + return box + StartHorizontal -> do newBox <- hBoxNew True 0 + boxPackStart box newBox PackNatural 0 + boxPackStart newBox w PackGrow 0 + return (castToBox newBox) + StopHorizontal -> do boxPackStart box w PackGrow 0 + par <- widgetGetParent box + case par of + Nothing -> throwIDE "initInfo - no parent" + Just p -> return (castToBox p)) + (castToBox ibox) + (zip widgets (map (getParameter paraHorizontal . parameters) + (idDescrDescr ideR))) + boxPackStart nbbox ibox PackGrow 0 + boxPackEnd nbbox bb PackNatural 0 + --openType + sw <- scrolledWindowNew Nothing Nothing + scrolledWindowAddWithViewport sw nbbox + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + currentIDs' <- newIORef idDescrs + currentInd <- newIORef 0 + let info = IDEInfo sw currentIDs' currentInd setInjs getExts nextB prevB label + + --mapM_ (\w -> widgetSetExtensionEvents w [ExtensionEventsAll]) widgets + cids <- mapM + (\w -> w `onFocus` --onFocusIn doesn't work here - why? + (\_ -> do runReaderT (makeActive info) ideR + return False)) + widgets + definitionB `onClicked` (runReaderT gotoSource ideR) + moduB `onClicked` (runReaderT gotoModule' ideR) + usesB `onClicked` (runReaderT calledBy' ideR) + nextB `onClicked` (next info) + prevB `onClicked` (prev info) + notebookInsertOrdered nb sw (paneName info) + widgetShowAll sw + return (info,cids) + addPaneAdmin pane (BufConnections [] [] []) panePath + lift $widgetGrabFocus (sw pane) + lift $bringPaneToFront pane + +next :: IDEInfo -> IO () +next (IDEInfo _ currentIDs' currentInd' injectors' _ nextB prevB label) = do + currentIdsU <- readIORef currentIDs' + currentIndU <- readIORef currentInd' + when (length currentIdsU > currentIndU + 1) $ do + writeIORef currentInd' (currentIndU + 1) + mapM_ (\ a -> a (currentIdsU !! (currentIndU + 1))) injectors' + when (length currentIdsU == currentIndU + 1) $ widgetSetSensitivity nextB False + widgetSetSensitivity prevB True + labelSetText label (show (currentIndU + 2) ++ "/" ++ show (length currentIdsU)) + + +prev :: IDEInfo -> IO () +prev (IDEInfo _ currentIDs' currentInd' injectors' _ nextB prevB label) = do + currentIdsU <- readIORef currentIDs' + currentIndU <- readIORef currentInd' + when (currentIndU >= 1) $ do + writeIORef currentInd' (currentIndU - 1) + mapM_ (\ a -> a (currentIdsU !! (currentIndU - 1))) injectors' + when (currentIndU - 1 == 0) $ widgetSetSensitivity prevB False + widgetSetSensitivity nextB True + labelSetText label (show currentIndU ++ "/" ++ show (length currentIdsU)) + +gotoSource :: IDEAction +gotoSource = do + mbInfo <- getInfoCont + case mbInfo of + Nothing -> do ideMessage Normal "gotoSource:noDefition" + return () + Just info -> do goToDefinition info + return () + +gotoModule' :: IDEAction +gotoModule' = do + mbInfo <- getInfoCont + ideR <- ask + case mbInfo of + Nothing -> return () + Just info -> do triggerEvent ideR (SelectIdent info) + return () + +calledBy' :: IDEAction +calledBy' = do + mbInfo <- getInfoCont + case mbInfo of + Nothing -> return () + Just info -> do calledBy info + return () + +setSymbol :: String -> IDEAction +setSymbol symbol = do + currentInfo' <- readIDE currentInfo + case currentInfo' of + Nothing -> return () + Just ((_,symbolTable1),(_,symbolTable2)) -> + case getIdentifierDescr symbol symbolTable1 symbolTable2 of + [] -> return () + a -> setInfos a + + +setInfos :: [IdentifierDescr] -> IDEM () +setInfos identifierDescrs = do + mbPane <- getPane InfoCasting + case mbPane of + Nothing -> do + prefs <- readIDE prefs + layout <- readIDE layout + let pp = getStandardPanePath (infoPanePath prefs) layout + nb <- getNotebook pp + initInfo pp nb identifierDescrs 0 + Just info -> lift $ do + writeIORef (currentInd info) 0 + writeIORef (currentIDs info) identifierDescrs + mapM_ (\ a -> a (head identifierDescrs)) (injectors info) + labelSetText (numLabel info) ("1/" ++ show (length identifierDescrs)) + widgetSetSensitivity (prevB info) False + widgetSetSensitivity (nextB info) + (if length identifierDescrs > 1 then True else False) + bringPaneToFront info + + +getInfoCont :: IDEM (Maybe (IdentifierDescr)) +getInfoCont = do + mbPane <- getPane InfoCasting + case mbPane of + Nothing -> return Nothing + Just p -> lift $ do + currentIndU <- readIORef (currentInd p) + currentIDsU <- readIORef (currentIDs p) + if length currentIDsU > currentIndU + then return (Just (currentIDsU !! currentIndU)) + else return Nothing + +-- +-- | Lookup of an identifier description +-- +getIdentifierDescr :: String -> SymbolTable -> SymbolTable -> [IdentifierDescr] +getIdentifierDescr str st1 st2 = + case str `Map.lookup` st1 of + Nothing -> case str `Map.lookup` st2 of + Nothing -> [] + Just list -> list + Just list -> case str `Map.lookup` st2 of + Nothing -> list + Just list2 -> list ++ list2 + diff --git a/src/IDE/Keymap.hs b/src/IDE/Keymap.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Keymap.hs @@ -0,0 +1,178 @@ +-- +-- | Module for handling keymaps, +-- | deals with gtk accelerators and double (emacs-like) keystrokes +-- + +module IDE.Keymap ( + Keymap(..) +) where + +import Graphics.UI.Gtk +import qualified Data.Map as Map +import Text.ParserCombinators.Parsec +import qualified Text.ParserCombinators.Parsec.Token as P +import Text.ParserCombinators.Parsec.Language(emptyDef) +import Data.Maybe +import Data.List(sort) +import Data.Char(toLower) +import Control.Monad.Reader + +import IDE.Core.State + +class IDEObject alpha => Keymap alpha where + parseKeymap :: FilePath -> IO alpha + setKeymap :: alpha -> [ActionDescr IDERef] -> [ActionDescr IDERef] + buildSpecialKeys :: alpha -> [ActionDescr IDERef] -> IO (SpecialKeyTable IDERef) + +instance IDEObject KeymapI + +instance Keymap KeymapI where + parseKeymap = parseKeymap' + setKeymap = setKeymap' + buildSpecialKeys = buildSpecialKeys' + +-- +-- | Loads and parses a keymap file +-- + +parseKeymap' :: FilePath -> IO KeymapI +parseKeymap' fn = do + res <- parseFromFile keymapParser fn + case res of + Left pe -> throwIDE $"Error reading keymap file " ++ show fn ++ " " ++ show pe + Right r -> return r + +-- +-- | Sets the accelerators is the action descriptions from the keymap +-- +setKeymap' :: KeymapI -> [ActionDescr IDERef] -> [ActionDescr IDERef] +setKeymap' (KM keymap) actions = map setAccel actions + where setAccel act = case Map.lookup (name act) keymap of + Nothing -> act + Just [] -> act + Just keyList -> foldl setAccelerator act keyList + setAccelerator act (Just (Left acc),Nothing) = act{accelerator= acc : accelerator act} + setAccelerator act (Just (Left acc),Just expl) = act{accelerator= acc : accelerator act, + tooltip= Just expl} + setAccelerator act (_, Just expl) = act{tooltip= Just expl} + setAccelerator act (_,_) = act + +-- +-- | Builds a special keymap for handling double keystroke accelerators +-- Unfortunately in the IO Monad because of keyvalFromName +-- +buildSpecialKeys' :: KeymapI -> [ActionDescr IDERef] -> IO (SpecialKeyTable IDERef) +buildSpecialKeys' (KM keymap) actions = do + pseudoTriples <- mapM build actions + let map1 = Map.fromListWith (++) $concat pseudoTriples + return (Map.map Map.fromList map1) + where + build :: ActionDescr IDERef -> IO [((KeyVal,[Modifier]),[((KeyVal,[Modifier]), + (ActionDescr IDERef))])] + build act = + case Map.lookup (name act) keymap of + Nothing -> return [] + Just l -> foldM (build' act) [] l + build' act list (Just (Right (a1,a2)),_) + = do a1p <- accParse a1 + a2p <- accParse a2 + return ((a1p,[(a2p,act)]): list) + build' act list _ = return list + + +-- --------------------------------------------------------------------- +-- Parsing +-- + +keymapStyle :: P.LanguageDef st +keymapStyle= emptyDef + { P.commentStart = "{-" + , P.commentEnd = "-}" + , P.commentLine = "--" + , P.identStart = alphaNum <|> oneOf "<>_" + , P.identLetter = alphaNum <|> oneOf "<>_" + } +lexer = P.makeTokenParser keymapStyle +lexeme = P.lexeme lexer +identifier = P.identifier lexer +symbol = P.symbol lexer +whiteSpace = P.whiteSpace lexer +stringLiteral = P.stringLiteral lexer + +keymapParser :: CharParser () KeymapI +keymapParser = do + whiteSpace + ls <- many lineparser + eof + return (KM (Map.fromListWith (++) ls)) + +lineparser :: CharParser () (ActionString, [(Maybe (Either KeyString + (KeyString,KeyString)), Maybe String)]) +lineparser = do + mb1 <- option Nothing (do + keyDescr <- identifier + mb2 <- option Nothing (do + symbol "/" + key <- identifier + return (Just key)) + return (Just (keyDescr, mb2))) + symbol "->" + action <- identifier + mbs <- option Nothing (do + str <- stringLiteral + return (Just str)) + return (case mb1 of + Nothing -> (action,[(Nothing,mbs)]) + Just (keyDescr,mb2) -> + case mb2 of + Just keyDescr2 -> (action,[(Just (Right (keyDescr,keyDescr2)),mbs)]) + Nothing -> (action,[(Just (Left keyDescr),mbs)])) + "lineparser" + +-------------------------------------------------- +-- Have to write this until gtk_accelerator_parse gets bound in gtk2hs +-- +accParse :: String -> IO (KeyVal,[Modifier]) +accParse str = case parse accparser "accelerator" str of + Right (ks,mods) -> do + key <- keyvalFromName (map toLower ks) + return (key,sort mods) + Left e -> throwIDE $show e + +accStyle :: P.LanguageDef st +accStyle= emptyDef{P.caseSensitive = False} + +lexer2 = P.makeTokenParser accStyle +lexeme2 = P.lexeme lexer2 +symbol2 = P.symbol lexer2 +identifier2 = P.identifier lexer2 +whiteSpace2 = P.whiteSpace lexer2 + +accparser :: GenParser Char () (String,[Modifier]) +accparser = do + whiteSpace2 + mods <- many modparser + key <- identifier2 + return (key,mods) + +modparser :: GenParser Char () Modifier +modparser = do + try $symbol2 "" + return Shift + <|> do + try $symbol2 "" + return Control + <|> do + try $symbol2 "" + return Control + <|> do + try $symbol2 "" + return Alt + <|> do + try $symbol2 "" + return Apple + <|> do + try $symbol2 "" + return Compose + "modparser" + diff --git a/src/IDE/Leksah.hs b/src/IDE/Leksah.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Leksah.hs @@ -0,0 +1,371 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Leksah +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- +-- Main function of Genuine Haskell Face, an Haskell IDE written in Haskell +-- +--------------------------------------------------------------------------------- + +module IDE.Leksah ( + runMain +) where + +import Graphics.UI.Gtk +import Control.Monad.Reader +import Control.Concurrent +import Data.IORef +import Data.Maybe +import Data.List(sort) +import qualified Data.Map as Map +import System.Console.GetOpt +import System.Environment +import GHC +import Config +import Data.Version +import Prelude hiding(catch) +import System.FilePath +import System.Directory + + +import Paths_leksah +import IDE.SaveSession +import IDE.Core.State +import IDE.SourceCandy +import IDE.Utils.File +import IDE.Framework.ViewFrame +import IDE.Framework.MakeEditor +import IDE.Framework.Parameters +import IDE.Menu +import IDE.Preferences +import IDE.Keymap +import IDE.SourceEditor +import IDE.SpecialEditors +import IDE.Metainfo.Info +import IDE.Metainfo.SourceCollector +import IDE.Metainfo.InterfaceCollector +import IDE.Log(getLog,appendLog) +import IDE.InfoPane +import IDE.ModulesPane + + +-- --------------------------------------------------------------------- +-- Command line options +-- + +data Flag = UninstalledProject String | Collect | Rebuild | Sources | VersionF | DebugF + deriving (Show,Eq) + +options :: [OptDescr Flag] +options = [Option ['r'] ["Rebuild"] (NoArg Rebuild) + "Cleans all .pack files and rebuild everything" + , Option ['c'] ["Collect"] (NoArg Collect) + "Collects new information in .pack files" + , Option ['u'] ["Uninstalled"] (ReqArg UninstalledProject "FILE") + "Gather info about an uninstalled package" + , Option ['s'] ["Sources"] (NoArg Sources) + "Gather info about pathes to sources" + , Option ['v'] ["Version"] (NoArg VersionF) + "Show the version number of ide" + , Option ['d'] ["Debug"] (NoArg DebugF) + "Write ascii pack files"] + +ideOpts :: [String] -> IO ([Flag], [String]) +ideOpts argv = + case getOpt Permute options argv of + (o,n,[] ) -> return (o,n) + (_,_,errs) -> ioError $userError $concat errs ++ usageInfo header options + where header = "Usage: ide [OPTION...] files..." + + +-- --------------------------------------------------------------------- +-- | Main function +-- + +runMain = handleTopExceptions $do + args <- getArgs + (o,_) <- ideOpts args + let uninstalled = filter (\x -> case x of + UninstalledProject _ -> True + _ -> False) o + if elem VersionF o + then do sysMessage Normal $ "Leksah an IDE for Haskell, version " ++ showVersion version + else + if elem Sources o + then do + buildSourceForPackageDB + sysMessage Normal "rebuild SourceForPackageDB" + else if elem Rebuild o + || elem Collect o + || not (null uninstalled) + then do + libDir <- getSysLibDir +#if __GHC__ > 670 + session <- newSession (Just libDir) +#else + session <- newSession JustTypecheck (Just libDir) +#endif + dflags0 <- getSessionDynFlags session + setSessionDynFlags session dflags0 + let version = cProjectVersion + let uninstalled = filter (\x -> case x of UninstalledProject _ -> True + _ -> False) o + let writeAscii = elem DebugF o + if length uninstalled > 0 + then mapM_ (collectUninstalled writeAscii session version) + $ map (\ (UninstalledProject x) -> x) uninstalled + else do + sources <- getSourcesMap + collectInstalled' writeAscii session version (elem Rebuild o) sources + else startGUI + +-- --------------------------------------------------------------------- +-- | Start the GUI + +startGUI :: IO () +startGUI = do +-- sysMessage Normal "Leksah says welcome" + st <- initGUI + when rtsSupportsBoundThreads + (sysMessage Normal "Linked with -threaded") + timeoutAddFull (yield >> return True) priorityHigh 25 + mapM_ (sysMessage Normal) st + uiManager <- uiManagerNew + newIcons + hasConfigDir' <- hasConfigDir + when (not hasConfigDir') firstStart + prefsPath <- getConfigFilePathForLoad "Default.prefs" + prefs <- readPrefs prefsPath + keysPath <- getConfigFilePathForLoad $keymapName prefs ++ ".keymap" + keyMap <- parseKeymap keysPath + let accelActions = setKeymap (keyMap :: KeymapI) actions + specialKeys <- buildSpecialKeys keyMap accelActions + candyPath <- getConfigFilePathForLoad + (case sourceCandy prefs of + Nothing -> "Default.candy" + Just name -> name ++ ".candy") + candySt <- parseCandy candyPath + win <- windowNew + dataDir <- getDataDir + let iconPath = dataDir "data" "leksah.png" + iconExists <- doesFileExist iconPath + when iconExists $ + windowSetIconFromFile win iconPath + libDir <- getSysLibDir +#if __GHC__ > 670 + session <- newSession (Just libDir) +#else + session <- newSession JustTypecheck (Just libDir) +#endif + dflags0 <- getSessionDynFlags session + setSessionDynFlags session dflags0 + let ide = IDE + { window = win + , uiManager = uiManager + , panes = Map.empty + , activePane = Nothing + , paneMap = Map.empty + , layout = (TerminalP Nothing (-1)) + , specialKeys = specialKeys + , specialKey = Nothing + , candy = candySt + , prefs = prefs +-- , packages = [] + , activePack = Nothing + , errors = [] + , currentErr = Nothing + , accessibleInfo = Nothing + , currentInfo = Nothing + , session = session + , handlers = Map.empty} + ideR <- newIORef ide + runReaderT (initInfo :: IDEAction) ideR + menuDescription' <- menuDescription + (acc,menus) <- runReaderT (makeMenu uiManager accelActions menuDescription') ideR + when (length menus /= 3) $ throwIDE ("Failed to build menu" ++ show (length menus)) + windowAddAccelGroup win acc + nb <- newNotebook + widgetSetName nb $"root" + statusBar <- buildStatusbar ideR + vb <- vBoxNew False 1 -- Top-level vbox + widgetSetName vb "topBox" + boxPackStart vb (menus !! 0) PackNatural 0 + boxPackStart vb nb PackGrow 0 + boxPackEnd vb statusBar PackNatural 0 + win `onDelete` (\ _ -> do runReaderT quit ideR; return True) + win `onKeyPress` (\ e -> runReaderT (handleSpecialKeystrokes e) ideR) + containerAdd win vb + runReaderT (setCandyState (isJust (sourceCandy prefs))) ideR + let (x,y) = defaultSize prefs + windowSetDefaultSize win x y + runReaderT (do + registerEvents menus + recoverSession :: IDEAction) ideR + widgetShowAll win + mainGUI + +-- +-- | Callback function for onKeyPress of the main window, so preprocess any key +-- +handleSpecialKeystrokes :: Event -> IDEM Bool +handleSpecialKeystrokes (Key _ _ _ mods _ _ _ keyVal name mbChar) = do + bs <- getCandyState + when bs $ editKeystrokeCandy mbChar + sk <- readIDE specialKey + sks <- readIDE specialKeys + sb <- getSBSpecialKeys + case sk of + Nothing -> do + case Map.lookup (keyVal,sort mods) sks of + Nothing -> do + lift $statusbarPop sb 1 + lift $statusbarPush sb 1 "" + return False + Just map -> do + sb <- getSBSpecialKeys + let sym = printMods mods ++ name + lift $statusbarPop sb 1 + lift $statusbarPush sb 1 sym + modifyIDE_ (\ide -> return (ide{specialKey = Just (map,sym)})) + return True + Just (map,sym) -> do + case Map.lookup (keyVal,sort mods) map of + Nothing -> do + sb <- getSBSpecialKeys + lift $statusbarPop sb 1 + lift $statusbarPush sb 1 $sym ++ printMods mods ++ name ++ "?" + return () + Just (AD actname _ _ _ ideAction _ _) -> do + sb <- getSBSpecialKeys + lift $statusbarPop sb 1 + lift $statusbarPush sb 1 + $sym ++ " " ++ printMods mods ++ name ++ "=" ++ actname + ideAction + modifyIDE_ (\ide -> return (ide{specialKey = Nothing})) + return True + where + printMods :: [Modifier] -> String + printMods [] = "" + printMods (m:r) = show m ++ printMods r +handleSpecialKeystrokes _ = return True + +registerEvents :: [Widget] -> IDEAction +registerEvents tbl = do + stRef <- ask + registerEvent stRef LogMessageS (Left logHandler) + registerEvent stRef GetToolbarS (Left tbHandler) + registerEvent stRef SelectInfoS (Left siHandler) + registerEvent stRef SelectIdentS (Left sidHandler) + registerEvent stRef CurrentInfoS (Left ciuHandler) + registerEvent stRef ActivePackS (Left apHandler) + + return () + where + logHandler e@(LogMessage s t) = do + (log :: IDELog) <- getLog + lift $ appendLog log s t + return e + logHandler _ = throwIDE "Leksah>>registerEvents: Impossible event" + + tbHandler (GetToolbar _) = return (GetToolbar tbl) + tbHandler _ = throwIDE "Leksah>>registerEvents: Impossible event" + + siHandler e@(SelectInfo str) = do + setSymbol str + return e + siHandler _ = throwIDE "Leksah>>registerEvents: Impossible event" + + sidHandler e@(SelectIdent id) = do + selectIdentifier id + return e + sidHandler _ = throwIDE "Leksah>>registerEvents: Impossible event" + + ciuHandler CurrentInfo = do + reloadKeepSelection + return CurrentInfo + ciuHandler _ = throwIDE "Leksah>>registerEvents: Impossible event" + + apHandler ActivePack = do + infoForActivePackage :: IDEAction + return ActivePack + apHandler _ = throwIDE "Leksah>>registerEvents: Impossible event" + + + +-- +-- | Called when leksah ist first called +-- +fDescription :: FieldDescription Prefs +fDescription = + mkField + (paraName <<<- ParaName "Paths under which haskell sources may be found" + $ paraDirection <<<- ParaDirection Vertical + $ emptyParams) + sourceDirectories + (\b a -> a{sourceDirectories = b}) + (filesEditor Nothing FileChooserActionSelectFolder "Select folders") + +firstStart :: IO () +firstStart = do + prefsPath <- getConfigFilePathForLoad "Default.prefs" + prefs <- readPrefs prefsPath + dialog <- windowNew + vb <- vBoxNew False 0 + bb <- hButtonBoxNew + ok <- buttonNewFromStock "gtk-ok" + cancel <- buttonNewFromStock "gtk-cancel" + boxPackStart bb ok PackNatural 0 + boxPackStart bb cancel PackNatural 0 + label <- labelNew (Just ("Welcome to Leksah, an IDE for Haskell.\n" ++ + "At the first start, Leksah will collect metadata about your installed haskell packages.\n" ++ + "Select folders under which you have installed Haskell packages with sources below and click add.\n" ++ + "It may take some time before Leksah starts up.")) + (widget, setInj, getExt,notifier) + <- fieldEditor fDescription prefs + ok `onClicked` (do + mbNewPrefs <- extract prefs [getExt] + case mbNewPrefs of + Nothing -> return () + Just newPrefs -> do + fp <- getConfigFilePathForSave "Default.prefs" + writePrefs fp newPrefs + widgetDestroy dialog + mainQuit + firstBuild) + cancel `onClicked` (do + widgetDestroy dialog + mainQuit) + dialog `onDelete` (\_ -> do + widgetDestroy dialog + mainQuit + return True) + boxPackStart vb label PackGrow 7 + boxPackStart vb widget PackGrow 7 + boxPackEnd vb bb PackNatural 7 + containerAdd dialog vb + widgetSetSizeRequest dialog 700 400 + widgetShowAll dialog + mainGUI + return () + +firstBuild :: IO () +firstBuild = do + libDir <- getSysLibDir +#if __GHC__ > 670 + session <- newSession (Just libDir) +#else + session <- newSession JustTypecheck (Just libDir) +#endif + dflags0 <- getSessionDynFlags session + setSessionDynFlags session dflags0 + let version = cProjectVersion + buildSourceForPackageDB + sources <- getSourcesMap + collectInstalled' False session version True sources diff --git a/src/IDE/Log.hs b/src/IDE/Log.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Log.hs @@ -0,0 +1,244 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +-- +-- Module : IDE.Log +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | Log pane +-- +------------------------------------------------------------------------------- + + +module IDE.Log ( + LogView(..) +, LogAction(..) +, IDELog(..) +, LogState +, LogTag(..) +) where + +import Graphics.UI.Gtk hiding (afterToggleOverwrite) +import Graphics.UI.Gtk.Multiline.TextView +import Control.Monad.Reader +import Data.Maybe + +import IDE.Core.State +import IDE.SourceEditor +import IDE.Framework.ViewFrame + + +------------------------------------------------------------------------------- +-- +-- * Interface +-- + +-- +-- | The Log Viev +-- + +class LogAction alpha where + clearLog :: alpha + +instance LogAction IDEAction where + clearLog = clearLog' + +class Pane alpha => LogView alpha where + getLog :: IDEM alpha + appendLog :: alpha -> String -> LogTag -> IO Int + markErrorInLog :: alpha -> (Int, Int) -> IO () + +instance IDEObject IDELog + +instance LogView IDELog + where + getLog = getLog' + appendLog = appendLog' + markErrorInLog = markErrorInLog' + +instance CastablePane IDELog where + casting _ = LogCasting + downCast _ (PaneC a) = case casting a of + LogCasting -> Just a + _ -> Nothing + + +instance Recoverable LogState where + toPaneState a = LogSt a + +instance Pane IDELog + where + primPaneName _ = "Log" + getAddedIndex _ = 0 + getTopWidget = castToWidget . scrolledWindowL + paneId b = "*Log" + makeActive log = do + activatePane log (BufConnections[][] []) + close pane = do + (panePath,_) <- guiPropertiesFromName (paneName pane) + nb <- getNotebook panePath + mbI <- lift $notebookPageNum nb (getTopWidget pane) + case mbI of + Nothing -> lift $ do + sysMessage Normal "notebook page not found: unexpected" + return () + Just i -> do + deactivatePaneIfActive pane + lift $notebookRemovePage nb i + removePaneAdmin pane + +instance RecoverablePane IDELog LogState where + saveState p = return (Just (StateC LogState)) + recoverState pp LogState = do + nb <- getNotebook pp + initLog pp nb + + +------------------------------------------------------------------------------- +-- +-- * Implementation +-- + + +initLog :: PanePath -> Notebook -> IDEAction +initLog panePath nb = do + ideR <- ask + panes <- readIDE panes + paneMap <- readIDE paneMap + prefs <- readIDE prefs + (buf,cids) <- lift $ do + tv <- textViewNew + buf <- textViewGetBuffer tv + iter <- textBufferGetEndIter buf + textBufferCreateMark buf (Just "end") iter True + + tags <- textBufferGetTagTable buf + errtag <- textTagNew (Just "err") + set errtag[textTagForeground := "red"] + textTagTableAdd tags errtag + frametag <- textTagNew (Just "frame") + set frametag[textTagForeground := "green"] + textTagTableAdd tags frametag + activeErrtag <- textTagNew (Just "activeErr") + set activeErrtag[textTagBackground := "yellow"] + textTagTableAdd tags activeErrtag + + textViewSetEditable tv True + fd <- case logviewFont prefs of + Just str -> do + fontDescriptionFromString str + Nothing -> do + f <- fontDescriptionNew + fontDescriptionSetFamily f "Sans" + return f + widgetModifyFont tv (Just fd) + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw tv + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + scrolledWindowSetShadowType sw ShadowIn + + let buf = IDELog tv sw + notebookInsertOrdered nb sw (paneName buf) + widgetShowAll (scrolledWindowL buf) + cid1 <- tv `afterFocusIn` + (\_ -> do runReaderT (makeActive buf) ideR; return True) + cid2 <- tv `onButtonPress` + (\ b -> do runReaderT (clicked b buf) ideR; return True) + return (buf,[cid1]) + addPaneAdmin buf (BufConnections [] [] cids) panePath + lift $widgetGrabFocus (textView buf) + +clicked :: Event -> IDELog -> IDEAction +clicked (Button _ SingleClick _ _ _ _ LeftButton x y) ideLog = do + errors' <- readIDE errors + line' <- lift $ do + (x,y) <- widgetGetPointer (textView ideLog) + (_,y') <- textViewWindowToBufferCoords (textView ideLog) TextWindowWidget (x,y) + (iter,_) <- textViewGetLineAtY (textView ideLog) y' + textIterGetLine iter + case filter (\(es,_) -> fst (logLines es) <= (line'+1) && snd (logLines es) >= (line'+1)) + (zip errors' [0..(length errors')]) of + [(thisErr,n)] -> do + succ <- selectSourceBuf (filePath thisErr) + if succ + then markErrorInSourceBuf (line thisErr) (column thisErr) + (errDescription thisErr) + else return () + log :: IDELog <- getLog + lift $ markErrorInLog log (logLines thisErr) + modifyIDE_ (\ide -> return (ide{currentErr = Just n})) + otherwise -> return () +clicked _ _ = return () + + +getLog' :: IDEM IDELog +getLog' = do + mbPane <- getPane LogCasting + case mbPane of + Nothing -> do + prefs <- readIDE prefs + layout <- readIDE layout + let pp = getStandardPanePath (logPanePath prefs) layout + nb <- getNotebook pp + initLog pp nb + mbPane <- getPane LogCasting + case mbPane of + Nothing -> throwIDE "Can't init log" + Just l -> return l + Just p -> return p + +simpleLog :: String -> IDEAction +simpleLog str = do + log :: IDELog <- getLog + lift $ appendLog log str LogTag + return () + +appendLog' :: IDELog -> String -> LogTag -> IO Int +appendLog' l@(IDELog tv _) string tag = do + buf <- textViewGetBuffer tv + iter <- textBufferGetEndIter buf + textBufferSelectRange buf iter iter + textBufferInsert buf iter string + iter2 <- textBufferGetEndIter buf + case tag of + LogTag -> return () + ErrorTag -> do + len <- textBufferGetCharCount buf + strti <- textBufferGetIterAtOffset buf (len - length string) + textBufferApplyTagByName buf "err" iter2 strti + FrameTag -> do + len <- textBufferGetCharCount buf + strti <- textBufferGetIterAtOffset buf (len - length string) + textBufferApplyTagByName buf "frame" iter2 strti + textBufferMoveMarkByName buf "end" iter2 + mbMark <- textBufferGetMark buf "end" + line <- textIterGetLine iter2 + case mbMark of + Nothing -> return () + Just mark -> textViewScrollMarkOnscreen tv mark + bringPaneToFront l + return line + +markErrorInLog' :: IDELog -> (Int,Int) -> IO () +markErrorInLog' (IDELog tv _) (l1,l2) = do + buf <- textViewGetBuffer tv + iter <- textBufferGetIterAtLineOffset buf (l1-1) 0 + iter2 <- textBufferGetIterAtLineOffset buf l2 0 + textBufferSelectRange buf iter iter2 +-- textBufferApplyTagByName buf "activeErr" iter iter2 + textBufferMoveMarkByName buf "end" iter + mbMark <- textBufferGetMark buf "end" + case mbMark of + Nothing -> return () + Just mark -> textViewScrollToMark tv mark 0.0 (Just (0.3,0.3)) + +clearLog' :: IDEAction +clearLog' = do + log <- getLog + buf <- lift$ textViewGetBuffer $textView log + lift $textBufferSetText buf "" + modifyIDE_ (\ide -> return (ide{errors = [], currentErr = Nothing})) + diff --git a/src/IDE/Menu.hs b/src/IDE/Menu.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Menu.hs @@ -0,0 +1,354 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Menu +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- +-- | Module for actions, menus and toolbars and the rest ... +-- +------------------------------------------------------------------------------- + + +module IDE.Menu ( + actions +, menuDescription +, makeMenu +, quit +, aboutDialog +, buildStatusbar +, newIcons +) where + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Types +import Control.Monad.Reader +import System.FilePath +import Data.Version + +import IDE.Core.State +import IDE.SourceEditor +import IDE.Framework.ViewFrame +import IDE.Preferences +import IDE.PackageEditor +import IDE.Package +import IDE.Log +import IDE.SaveSession +import IDE.ModulesPane +import IDE.ToolbarPane +import IDE.FindPane +import IDE.ReplacePane +import IDE.Utils.File +import Paths_leksah + +-- +-- | The Actions known to the system (they can be activated by keystrokes or menus) +-- +actions :: [ActionDescr IDERef] +actions = + [(AD "File" "_File" Nothing Nothing (return ()) [] False) + ,(AD "FileNew" "_New" Nothing (Just "gtk-new") + fileNew [] False) + ,AD "FileOpen" "_Open" Nothing (Just "gtk-open") + fileOpen [] False + ,AD "FileRevert" "_Revert" Nothing Nothing + fileRevert [] False + ,AD "FileSave" "_Save" Nothing (Just "gtk-save") + (fileSave False) [] False + ,AD "FileSaveAs" "Save_As" Nothing (Just "gtk-save_as") + (fileSave True) [] False + ,AD "FileClose" "_Close" Nothing (Just "gtk-close") + (do fileClose; return ()) [] False + ,AD "FileCloseAll" "Close All" Nothing Nothing + (do fileCloseAll; return ()) [] False + ,AD "FileCloseAllButPackage" "Close All But Package" Nothing Nothing + (do fileCloseAllButPackage; return ()) [] False + ,AD "Quit" "_Quit" Nothing (Just "gtk-quit") + quit [] False + + ,AD "Edit" "_Edit" Nothing Nothing (return ()) [] False + ,AD "EditUndo" "_Undo" Nothing (Just "gtk-undo") + editUndo [] False + ,AD "EditRedo" "_Redo" Nothing (Just "gtk-redo") + editRedo [] False + ,AD "EditCut" "Cu_t" Nothing Nothing{--Just "gtk-cut"--} + editCut [] {--Just "X"--} False + ,AD "EditCopy" "_Copy" Nothing Nothing{--Just "gtk-copy"--} + editCopy [] {--Just "C"--} False + ,AD "EditPaste" "_Paste" Nothing Nothing{--Just "gtk-paste"--} + editPaste [] {--Just "V"--} False + ,AD "EditDelete" "_Delete" Nothing (Just "gtk-delete") + editDelete [] False + ,AD "EditSelectAll" "Select_All" Nothing (Just "gtk-select-all") + editSelectAll [] False + ,AD "EditFind" "Find" Nothing (Just "gtk-find") + (editFindInc Initial) [] False + ,AD "EditFindNext" "Find _Next" Nothing (Just "gtk-find-next") + (editFindInc Forward) [] False + ,AD "EditFindPrevious" "Find _Previous" Nothing (Just "gtk-find-previous") + (editFindInc Backward) [] False + ,AD "EditReplace" "_Replace" Nothing (Just "gtk-replace") + doReplace [] False + ,AD "EditGotoLine" "_Goto Line" Nothing (Just "gtk-jump") + editGotoLine [] False + + ,AD "EditComment" "_Comment" Nothing Nothing + editComment [] False + ,AD "EditUncomment" "_Uncomment" Nothing Nothing + editUncomment [] False + ,AD "EditShiftRight" "Shift _Right" Nothing Nothing + editShiftRight [] False + ,AD "EditShiftLeft" "Shift _Left" Nothing Nothing + editShiftLeft [] False + + ,AD "EditCandy" "_To Candy" Nothing Nothing + editCandy [] True + + ,AD "Package" "Package" Nothing Nothing (return ()) [] False + ,AD "NewPackage" "_New Package" Nothing Nothing + packageNew [] False + ,AD "OpenPackage" "_Open Package" Nothing Nothing + packageOpen [] False + ,AD "EditPackage" "_Edit Package" Nothing Nothing + packageEdit [] False + ,AD "ClosePackage" "_Close Package" Nothing Nothing + deactivatePackage [] False + + ,AD "PackageFlags" "Edit Flags" Nothing Nothing + packageFlags [] False + ,AD "ConfigPackage" "_Configure Package" Nothing (Just "ide_configure") + packageConfig [] False + ,AD "BuildPackage" "_Build Package" Nothing (Just "ide_make") + packageBuild [] False + ,AD "DocPackage" "_Build Documentation" Nothing Nothing + packageDoc [] False + ,AD "CleanPackage" "Cl_ean Package" Nothing Nothing + packageClean [] False + ,AD "CopyPackage" "_Copy Package" Nothing Nothing + packageCopy [] False + ,AD "RunPackage" "_Run" Nothing (Just "ide_run") + packageRun [] False + ,AD "NextError" "_Next Error" Nothing (Just "ide_error_next") + nextError [] False + ,AD "PreviousError" "_Previous Error" Nothing (Just "ide_error_prev") + previousError [] False + + ,AD "InstallPackage" "_Install Package" Nothing Nothing + packageInstall [] False + ,AD "RegisterPackage" "_Register Package" Nothing Nothing + packageRegister [] False + ,AD "UnregisterPackage" "_Unregister" Nothing Nothing + packageUnregister [] False + ,AD "TestPackage" "Test Package" Nothing Nothing + packageTest [] False + ,AD "SdistPackage" "Source Dist" Nothing Nothing + packageSdist [] False + ,AD "OpenDocPackage" "_Open Doc" Nothing Nothing + packageOpenDoc [] False + + ,AD "View" "_View" Nothing Nothing (return ()) [] False + ,AD "ViewMoveLeft" "Move _Left" Nothing Nothing + (viewMove LeftP) [] False + ,AD "ViewMoveRight" "Move _Right" Nothing Nothing + (viewMove RightP) [] False + ,AD "ViewMoveUp" "Move _Up" Nothing Nothing + (viewMove TopP) [] False + ,AD "ViewMoveDown" "Move _Down" Nothing Nothing + (viewMove BottomP) [] False + ,AD "ViewSplitHorizontal" "Split H_orizontal" Nothing Nothing + viewSplitHorizontal [] False + ,AD "ViewSplitVertical" "Split _Vertical" Nothing Nothing + viewSplitVertical [] False + ,AD "ViewCollapse" "_Collapse" Nothing Nothing + viewCollapse [] False + + ,AD "ViewTabsLeft" "Tabs Left" Nothing Nothing + (viewTabsPos PosLeft) [] False + ,AD "ViewTabsRight" "Tabs Right" Nothing Nothing + (viewTabsPos PosRight) [] False + ,AD "ViewTabsUp" "Tabs Up" Nothing Nothing + (viewTabsPos PosTop) [] False + ,AD "ViewTabsDown" "Tabs Down" Nothing Nothing + (viewTabsPos PosBottom) [] False + ,AD "ViewSwitchTabs" "Tabs On/Off" Nothing Nothing + viewSwitchTabs [] False + + ,AD "ViewClosePane" "Close pane" Nothing (Just "gtk-close") + sessionClosePane [] False + + ,AD "ClearLog" "_Clear Log" Nothing Nothing + clearLog [] False + ,AD "ShowToolbar" "Show Toolbar" Nothing Nothing + (do getToolbar; return ()) [] False + ,AD "ShowFind" "Show Find" Nothing Nothing + doFind [] False + ,AD "ShowReplace" "Show Replace" Nothing Nothing + doReplace [] False + ,AD "ShowModules" "Show Modules" Nothing Nothing + showModules [] False + + + + ,AD "Help" "_Help" Nothing Nothing (return ()) [] False + ,AD "PrefsEdit" "_Edit Prefs" Nothing Nothing + editPrefs [] False + ,AD "HelpDebug" "Debug" Nothing Nothing (do + pack <- readIDE activePack + ideMessage Normal (show pack)) [] False +-- ,AD "HelpDebug2" "Debug2" (Just "d") Nothing dbgInstalledPackageInfo [] False + ,AD "HelpAbout" "About" Nothing (Just "gtk-about") aboutDialog [] False] + +-- +-- | The menu description in XML Syntax as defined by GTK +-- +menuDescription :: IO String +menuDescription = do + prefsPath <- getConfigFilePathForLoad "Default.menu" + res <- readFile prefsPath + return res + +-- +-- | Building the Menu +-- +makeMenu :: UIManager -> [ActionDescr IDERef] -> String -> IDEM (AccelGroup, [Widget]) +makeMenu uiManager actions menuDescription = do + ideR <- ask + lift $ do + actionGroupGlobal <- actionGroupNew "global" + mapM_ (actm ideR actionGroupGlobal) actions + uiManagerInsertActionGroup uiManager actionGroupGlobal 1 + uiManagerAddUiFromString uiManager menuDescription + accGroup <- uiManagerGetAccelGroup uiManager + mbWidgets <- mapM (uiManagerGetWidget uiManager) ["ui/menubar","ui/toolbar1","ui/toolbar2"] + let widgets = map (\mb -> case mb of + Just it -> it + Nothing -> throwIDE "Menu>>makeMenu: failed to build menu") mbWidgets + return (accGroup,widgets) + where + actm ideR ag (AD name label tooltip stockId ideAction accs isToggle) = do + let (acc,accString) = if null accs + then (Just "","=" ++ name) + else (Just (head accs),(head accs) ++ "=" ++ name) + if isToggle + then do + act <- toggleActionNew name label tooltip stockId + onToggleActionToggled act (doAction ideAction ideR accString) + actionGroupAddActionWithAccel ag act acc + else do + act <- actionNew name label tooltip stockId + onActionActivate act (doAction ideAction ideR accString) + actionGroupAddActionWithAccel ag act acc + doAction ideAction ideR accStr = + runReaderT (do + ideAction + sb <- getSBSpecialKeys + lift $statusbarPop sb 1 + lift $statusbarPush sb 1 $accStr + return ()) ideR + +-- | Quit ide +-- ### make reasonable +-- +quit :: IDEAction +quit = do + saveSession :: IDEAction + b <- fileCloseAll + if b + then lift mainQuit + else return () + +-- +-- | Show the about dialog +-- +aboutDialog :: IDEAction +aboutDialog = lift $ do + d <- aboutDialogNew + aboutDialogSetName d "Leksah" + aboutDialogSetVersion d (showVersion version) + aboutDialogSetCopyright d "Copyright 2007 Juergen Nicklisch-Franken aka Jutaro" + aboutDialogSetComments d $ "An integrated development environement (IDE) for the " ++ + "programming language Haskell and the Glasgow Haskell compiler" + dd <- getDataDir + license <- readFile $ dd "data" "gpl.txt" + aboutDialogSetLicense d $ Just license + aboutDialogSetWebsite d "code.haskell.org/leksah" + aboutDialogSetAuthors d ["Juergen Nicklisch-Franken aka Jutaro"] + dialogRun d + widgetDestroy d + return () + +buildStatusbar ideR = do + sb <- statusbarNew + statusbarSetHasResizeGrip sb False + + sblk <- statusbarNew + widgetSetName sblk "statusBarSpecialKeys" + statusbarSetHasResizeGrip sblk False + widgetSetSizeRequest sblk 150 (-1) + + sbap <- statusbarNew + widgetSetName sbap "statusBarActivePane" + statusbarSetHasResizeGrip sbap False + widgetSetSizeRequest sbap 150 (-1) + + sbapr <- statusbarNew + widgetSetName sbapr "statusBarActiveProject" + statusbarSetHasResizeGrip sbapr False + widgetSetSizeRequest sbapr 150 (-1) + + sbe <- statusbarNew + widgetSetName sbe "statusBarErrors" + statusbarSetHasResizeGrip sbe False + widgetSetSizeRequest sbe 150 (-1) + + sblc <- statusbarNew + widgetSetName sblc "statusBarLineColumn" + statusbarSetHasResizeGrip sblc True + widgetSetSizeRequest sblc 150 (-1) + + sbio <- statusbarNew + widgetSetName sbio "statusBarInsertOverwrite" + statusbarSetHasResizeGrip sbio False + widgetSetSizeRequest sbio 60 (-1) + + dummy <- hBoxNew False 1 + widgetSetName dummy "dummyBox" + + + hb <- hBoxNew False 1 + widgetSetName hb "statusBox" + boxPackStart hb sblk PackGrow 0 + boxPackStart hb sbap PackGrow 0 + boxPackStart hb sbapr PackGrow 0 + --boxPackStart hb dummy PackGrow 0 + boxPackEnd hb sblc PackNatural 0 + boxPackEnd hb sbio PackNatural 0 + boxPackEnd hb sbe PackNatural 0 + + return hb + +newIcons :: IO () +newIcons = do + iconFactory <- iconFactoryNew + dataDir <- getDataDir + mapM_ (loadIcon dataDir iconFactory) ["ide_class","ide_configure","ide_data","ide_error_next", + "ide_error_prev","ide_field","ide_function","ide_instance", "ide_konstructor","ide_make", + "ide_method","ide_newtype","ide_no_source","ide_other","ide_rule","ide_run","ide_slot", + "ide_source","ide_type","leksah" + ] + iconFactoryAddDefault iconFactory + where + loadIcon dataDir iconFactory name = do + pb <- pixbufNewFromFile $ dataDir "data" (name ++ ".png") + icon <- iconSetNewFromPixbuf pb + iconFactoryAdd iconFactory name icon + + + + + diff --git a/src/IDE/Metainfo/Info.hs b/src/IDE/Metainfo/Info.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Metainfo/Info.hs @@ -0,0 +1,391 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Metainfo.Info +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | This module provides the infos collected by the extractor before +-- and an info pane to present some of them to the user +-- +--------------------------------------------------------------------------------- + +module IDE.Metainfo.Info ( + InfoAction(..) +) where + +import System.IO +import qualified Data.Map as Map +import Config +import Control.Monad +import Control.Monad.Trans +import System.FilePath +import System.Directory +import qualified Data.Map as Map +import System.IO +import Data.List +import qualified PackageConfig as DP +import Data.Maybe +import Data.Binary +import qualified Data.ByteString.Lazy as BS +import Distribution.Package +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Map (Map) +import Data.ByteString.Char8 (ByteString) +import System.Process(ProcessHandle,getProcessExitCode) +import System.Glib.MainLoop(timeoutAddFull,priorityDefaultIdle) +import Control.Monad.Reader(runReaderT,ask) +import Distribution.Version + +import IDE.Utils.DeepSeq +import IDE.Utils.File +import IDE.Core.State +import IDE.Metainfo.InterfaceCollector + +class InfoAction alpha where + -- | Initialize metadata for the world + initInfo :: alpha + -- | Update world metadata + updateAccessibleInfo :: alpha + -- | Builds the current info for a package + -- Called when a package gets active or after a reconfigure + infoForActivePackage :: alpha + -- | Builds the current info for the activePackage in the background. + -- If a process handle is given, it waits for this process to finish before building + -- and only rebuilds if build was successful + -- Called after a build + mayRebuildInBackground :: Maybe ProcessHandle -> alpha + -- | Rebuild current info + rebuildActiveInfo :: alpha + +instance InfoAction IDEAction where + initInfo = initInfo' + updateAccessibleInfo = updateAccessibleInfo' + infoForActivePackage = infoForActivePackage' + mayRebuildInBackground = mayRebuildInBackground' + rebuildActiveInfo = setInfo buildActiveInfo + +-- +-- | Update and initialize metadata for the world +-- +initInfo' :: IDEAction +initInfo' = do + session' <- readIDE session + ideMessage Normal "Now updating metadata ..." + lift $ collectInstalled session' False + ideMessage Normal "Now loading metadata ..." + loadAccessibleInfo + ideMessage Normal "Finished loading ..." + +-- +-- | Load all infos for all installed and exposed packages +-- (see shell command: ghc-pkg list) +-- +loadAccessibleInfo :: IDEAction +loadAccessibleInfo = + let version = cProjectVersion in do + session' <- readIDE session + + collectorPath <- lift $ getCollectorPath version + packageInfos <- lift $ getInstalledPackageInfos session' + packageList <- lift $ mapM (loadInfosForPackage collectorPath) + (map (fromDPid . DP.package) packageInfos) + let scope = foldr buildScope (Map.empty,Map.empty) + $ map fromJust + $ filter isJust packageList + modifyIDE_ (\ide -> return (ide{accessibleInfo = (Just scope)})) + +-- +-- | Clears the current info, not the world infos +-- +clearCurrentInfo :: IDEAction +clearCurrentInfo = do + modifyIDE_ (\ide -> return (ide{currentInfo = Nothing})) + ideR <- ask + triggerEvent ideR CurrentInfo + return () + +-- +-- | Set info for package +-- +infoForActivePackage' :: IDEAction +infoForActivePackage' = do + activePack <- readIDE activePack + case activePack of + Nothing -> do + modifyIDE_ (\ide -> return (ide{currentInfo = Nothing})) + Just pack -> do + let depends' = depends pack + session' <- readIDE session + fp <- lift $findFittingPackages session' depends' + mbActive <- loadOrBuildActiveInfo + case mbActive of + Nothing -> do + -- no meta info available + modifyIDE_ (\ide -> return (ide{currentInfo = Nothing})) + Just active -> do + + accessibleInfo' <- readIDE accessibleInfo + case accessibleInfo' of + Nothing -> modifyIDE_ (\ide -> return (ide{currentInfo = Nothing})) + Just (pdmap,_) -> do + let packageList = map (\ pin -> pin `Map.lookup` pdmap) fp + let scope = foldr buildScope (Map.empty,Map.empty) + $ map fromJust + $ filter isJust packageList + modifyIDE_ (\ide -> return (ide{currentInfo = Just (active, scope)})) + ideR <- ask + triggerEvent ideR CurrentInfo + return () + + +-- +-- | Builds the current info for the activePackage in the background +-- If a process handle is given, it waits for this process to finish before building +-- +mayRebuildInBackground' :: Maybe ProcessHandle -> IDEAction +mayRebuildInBackground' mbHandle = do + ideR <- ask + lift $ do + timeoutAddFull (myRebuild ideR) priorityDefaultIdle 500 + return () + where + myRebuild :: IDERef -> IO Bool + myRebuild ideR = + case mbHandle of + Just hdl -> do + mbExitCode <- getProcessExitCode hdl + case mbExitCode of + --process not finished, wait for next call + Nothing -> return True + Just _ -> doIt ideR + Nothing -> doIt ideR + doIt :: IDERef -> IO Bool + doIt ideR = do + runReaderT (do + errs <- readIDE errors + when (length (filter isError errs) == 0) $ do + ideMessage Normal "Update meta info for active package" + setInfo buildActiveInfo) ideR + return False + +-- +-- | Builds the current info for the activePackage +-- +setInfo :: IDEM (Maybe PackageScope) -> IDEAction +setInfo f = do + currentInfo <- readIDE currentInfo + case currentInfo of + Nothing -> return () + Just (active, scope) -> do + newActive <- f + case newActive of + Nothing -> return () + Just newActive -> do + modifyIDE_ (\ide -> return (ide{currentInfo = Just (newActive, scope)})) + ideR <- ask + triggerEvent ideR CurrentInfo + return () + +-- +-- | Loads the current info for the activePackage, or builds it if not available +-- +loadOrBuildActiveInfo :: IDEM (Maybe PackageScope) +loadOrBuildActiveInfo = do + mbActiveInfo <- loadActiveInfo + case mbActiveInfo of + Just ai -> return (Just ai) + Nothing -> buildActiveInfo + +-- +-- | Loads the current info for the activePackage +-- +loadActiveInfo :: IDEM (Maybe PackageScope) +loadActiveInfo = + let version = cProjectVersion in do + activePack <- readIDE activePack + session <- readIDE session + case activePack of + Nothing -> return Nothing + Just idePackage -> do + collectorPath <- lift $ getCollectorPath cProjectVersion + packageDescr <- lift $ loadInfosForPackage collectorPath + (packageId idePackage) + case packageDescr of + Nothing -> return Nothing + Just pd -> do + let scope = buildScope pd (Map.empty,Map.empty) + return (Just scope) + +-- +-- | Builds the current info for the activePackage +-- +buildActiveInfo :: IDEM (Maybe PackageScope) +buildActiveInfo = + let version = cProjectVersion in do + activePack <- readIDE activePack + session <- readIDE session + case activePack of + Nothing -> return Nothing + Just idePackage -> do + lift $ collectUninstalled False session cProjectVersion (cabalFile idePackage) + -- ideMessage Normal "uninstalled collected" + collectorPath <- lift $ getCollectorPath cProjectVersion + packageDescr <- lift $ loadInfosForPackage collectorPath + (packageId idePackage) + case packageDescr of + Nothing -> return Nothing + Just pd -> do + let scope = buildScope pd (Map.empty,Map.empty) + return (Just scope) + +-- +-- | Updates the world info (it is the responsibility of the caller to rebuild +-- the current info) +-- +updateAccessibleInfo' :: IDEAction +updateAccessibleInfo' = do + wi <- readIDE accessibleInfo + session <- readIDE session + let version = cProjectVersion + case wi of + Nothing -> loadAccessibleInfo + Just (psmap,psst) -> do + packageInfos <- lift $ getInstalledPackageInfos session + let packageIds = map (fromDPid . DP.package) packageInfos + let newPackages = filter (\ pi -> Map.member pi psmap) packageIds + let trashPackages = filter (\ e -> not (elem e packageIds))(Map.keys psmap) + if null newPackages && null trashPackages + then return () + else do + collectorPath <- lift $ getCollectorPath version + newPackageInfos <- lift $ mapM (\pid -> loadInfosForPackage collectorPath pid) + newPackages + let psamp2 = foldr (\e m -> Map.insert (packagePD e) e m) + psmap + (map fromJust + $ filter isJust newPackageInfos) + let psamp3 = foldr (\e m -> Map.delete e m) psmap trashPackages + let scope = foldr buildScope (Map.empty,Map.empty) + (Map.elems psamp3) + modifyIDE_ (\ide -> return (ide{accessibleInfo = Just scope})) + +-- +-- | Loads the infos for the given packages +-- +loadInfosForPackage :: FilePath -> PackageIdentifier -> IO (Maybe PackageDescr) +loadInfosForPackage dirPath pid = do + let filePath = dirPath showPackageId pid ++ ".pack" + exists <- doesFileExist filePath + if exists + then catch (do + file <- openBinaryFile filePath ReadMode + bs <- BS.hGetContents file + let packageInfo = decode bs + packageInfo `deepSeq` (hClose file) + return (Just packageInfo)) + (\e -> do sysMessage Normal (show e); return Nothing) + else do + sysMessage Normal $"packageInfo not found for " ++ showPackageId pid + return Nothing + +-- +-- | Loads the infos for the given packages (has an collecting argument) +-- +buildScope :: PackageDescr -> PackageScope -> PackageScope +buildScope packageD (packageMap, symbolTable) = + let pid = packagePD packageD + in if pid `Map.member` packageMap + then (packageMap, symbolTable) + else (Map.insert pid packageD packageMap, + buildSymbolTable packageD symbolTable) + +buildSymbolTable :: PackageDescr -> SymbolTable -> SymbolTable +buildSymbolTable pDescr symbolTable = + foldl (\ st idDescr -> let allIds = identifierID idDescr : (allConstructorsID idDescr + ++ allFieldsID idDescr ++ allClassOpsID idDescr) + in foldl (\ st2 id -> Map.insertWith (++) id [idDescr] st2) st allIds) + symbolTable (idDescriptionsPD pDescr) + + + +-- --------------------------------------------------------------------- +-- DeepSeq instances for forcing evaluation +-- + +instance DeepSeq Location where + deepSeq pd = deepSeq (locationSLine pd) + $ deepSeq (locationSCol pd) + $ deepSeq (locationELine pd) + $ deepSeq (locationECol pd) + +instance DeepSeq PackageDescr where + deepSeq pd = deepSeq (packagePD pd) + $ deepSeq (mbSourcePathPD pd) + $ deepSeq (exposedModulesPD pd) + $ deepSeq (buildDependsPD pd) + $ deepSeq (idDescriptionsPD pd) + +instance DeepSeq ModuleDescr where + deepSeq pd = deepSeq (moduleIdMD pd) + $ deepSeq (mbSourcePathMD pd) + $ deepSeq (exportedNamesMD pd) + $ deepSeq (usagesMD pd) + +instance DeepSeq IdentifierDescr where + deepSeq (SimpleDescr identifierID' identifierTypeID' typeInfoID' moduleIdID' + mbLocation' mbComment') = deepSeq identifierID' + $ deepSeq identifierTypeID' + $ deepSeq typeInfoID' + $ deepSeq moduleIdID' + $ deepSeq mbLocation' + $ deepSeq mbComment' + deepSeq (DataDescr identifierID' typeInfoID' moduleIdID' constructorsID' fieldsID' + mbLocation' mbComment') = deepSeq identifierID' + $ deepSeq typeInfoID' + $ deepSeq moduleIdID' + $ deepSeq constructorsID' + $ deepSeq fieldsID' + $ deepSeq mbLocation' + $ deepSeq mbComment' + deepSeq (ClassDescr identifierID' typeInfoID' classOpsID' moduleIdID' + mbLocation' mbComment') = deepSeq identifierID' + $ deepSeq typeInfoID' + $ deepSeq moduleIdID' + $ deepSeq classOpsID' + $ deepSeq mbLocation' + $ deepSeq mbComment' + deepSeq (InstanceDescr identifierID' classID' moduleIdID' + mbLocation' mbComment') = deepSeq identifierID' + $ deepSeq classID' + $ deepSeq moduleIdID' + $ deepSeq mbLocation' + $ deepSeq mbComment' + +instance DeepSeq PackageIdentifier where + deepSeq pd = deepSeq (pkgName pd) + $ deepSeq (pkgVersion pd) + +instance DeepSeq alpha => DeepSeq (Set alpha) where + deepSeq s = deepSeq (Set.elems s) + +instance (DeepSeq alpha, DeepSeq beta) => DeepSeq (Map alpha beta) where + deepSeq s = deepSeq (Map.toList s) + +instance DeepSeq IdType where deepSeq = seq + +instance DeepSeq IdTypeS where deepSeq = seq + +instance DeepSeq ByteString where deepSeq = seq + +instance DeepSeq Version where deepSeq = seq + +instance DeepSeq PackModule where + deepSeq pd = deepSeq (pack pd) + $ deepSeq (modu pd) + diff --git a/src/IDE/Metainfo/InterfaceCollector.hs b/src/IDE/Metainfo/InterfaceCollector.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Metainfo/InterfaceCollector.hs @@ -0,0 +1,621 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Metainfo.InterfaceCollector +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | This modulle extracts information from .hi files for installed packages +-- +------------------------------------------------------------------------------- + +module IDE.Metainfo.InterfaceCollector ( + collectInstalled +, collectInstalledI +, collectInstalled' +, collectUninstalled +, getInstalledPackageInfos +, asDPid +, fromDPid +, findFittingPackages + +) where + + +import GHC hiding(Id,Failed,Succeeded) +import Module +import TcRnMonad +import qualified Maybes as M +import HscTypes +import LoadIface +import Outputable hiding(trace) +import IfaceSyn +import FastString +import Outputable hiding(trace) +import qualified PackageConfig as DP +import Name +import PrelNames +import PackageConfig(mainPackageId,unpackPackageId,mkPackageId) +import Maybes +import TcRnTypes +import Finder +import qualified FastString as FS +import ErrUtils +import Config(cProjectVersion) +import UniqFM + +import Data.List (maximumBy) +import Data.Char (isSpace) +import qualified Data.Map as Map +import Data.Map (Map) +import Data.Maybe +import qualified Data.Set as Set +import Data.Set (Set) +import System.Directory +import qualified PackageConfig as DP +import Distribution.PackageDescription +import Distribution.InstalledPackageInfo hiding (package) +import Distribution.Package +import Distribution.Verbosity +import Distribution.Version +import Control.Monad.Reader +import System.IO +import Data.Maybe +import System.FilePath +import System.Directory +import Data.List(zip4,nub) +import Data.Binary +import qualified Data.ByteString.Char8 as BS + + +import IDE.Utils.Default +import IDE.Core.State +import IDE.Utils.File +--import IDE.Metainfo.Info +import IDE.Metainfo.SourceCollector + +data CollectStatistics = CollectStatistics { + packagesTotal :: Int +, packagesWithSource :: Int +, modulesTotal :: Int +, modulesWithSource :: Int +, parseFailures :: Int +} deriving Show + +instance Default CollectStatistics where + getDefault = CollectStatistics getDefault getDefault getDefault getDefault + getDefault + +collectInstalledI :: Bool -> IDEAction +collectInstalledI b = do + session' <- readIDE session + sources <- lift $ getSourcesMap + lift $ collectInstalled' False session' cProjectVersion b sources + + +collectInstalled :: Session -> Bool -> IO () +collectInstalled session b = do + sources <- getSourcesMap + collectInstalled' False session cProjectVersion b sources + +collectInstalled' :: Bool -> Session -> String -> Bool -> Map PackageIdentifier [FilePath] -> IO() +collectInstalled' writeAscii session version forceRebuild sources = do + collectorPath <- getCollectorPath version + when forceRebuild $ do + removeDirectoryRecursive collectorPath + getCollectorPath version + return () + knownPackages <- findKnownPackages collectorPath + packageInfos <- getInstalledPackageInfos session + let newPackages = filter (\pi -> not $Set.member (showPackageId $ fromDPid $ DP.package pi) + knownPackages) + packageInfos + exportedIfaceInfos <- mapM (\ info -> getIFaceInfos (DP.mkPackageId $ DP.package info) + (DP.exposedModules info) session) newPackages + hiddenIfaceInfos <- mapM (\ info -> getIFaceInfos (DP.mkPackageId $ DP.package info) + (DP.hiddenModules info) session) newPackages + let extracted = map extractInfo $ zip4 exportedIfaceInfos + hiddenIfaceInfos + (map (fromDPid . DP.package) newPackages) + ((map (\p -> map fromDPid (DP.depends p))) + newPackages) + (extracted',failedToParse) <- collectAllSources session sources extracted + let statistic = CollectStatistics { + packagesTotal = length newPackages + , packagesWithSource = length $ filter (\p -> isJust (mbSourcePathPD p)) extracted' + , modulesTotal = foldl (\n p -> n + length (exposedModulesPD p)) 0 extracted' + , modulesWithSource = foldl (\n p -> n + length ( + filter (\p -> isJust (mbSourcePathMD p)) (exposedModulesPD p))) + 0 extracted' + , parseFailures = failedToParse} + sysMessage Normal $ show statistic + when (modulesWithSource statistic > 0) $ + sysMessage Normal $ "failure percentage " + ++ show ((round (((fromIntegral (parseFailures statistic)) :: Double) / + (fromIntegral (modulesWithSource statistic)) * 100.0)):: Integer) + mapM_ (writeExtracted collectorPath writeAscii) extracted' + +collectUninstalled :: Bool -> Session -> String -> FilePath -> IO () +collectUninstalled writeAscii session version cabalPath = do + pd <- readPackageDescription normal cabalPath + >>= return . flattenPackageDescription + let modules = nub $ exeModules pd ++ libModules pd + let basePath = takeDirectory cabalPath + let buildPath = "dist" "build" pkgName (package pd) + (pkgName (package pd) ++ "-tmp/") + dflags0 <- getSessionDynFlags session + setSessionDynFlags session + dflags0 + { topDir = basePath + , importPaths = [buildPath] + --, thisPackage = mkPackageId (package pd) + , ghcMode = OneShot + } + dflags1 <- getSessionDynFlags session + (dflags2,_) <- parseDynamicFlags dflags1 ["-fglasgow-exts","-haddock"] + setSessionDynFlags session dflags2 + allIfaceInfos <- getIFaceInfos2 modules session + deps <- findFittingPackages session (buildDepends pd) + let extracted = extractInfo (allIfaceInfos,[], package pd, deps) + let sources = Map.fromList [(package pd,[cabalPath])] + (extractedWithSources,_) <- collectSources session sources extracted + collectorPath <- getCollectorPath version + writeExtracted collectorPath writeAscii extractedWithSources + writeExtracted collectorPath True extractedWithSources + sysMessage Normal $ "\nExtracted infos for " ++ cabalPath + +------------------------------------------------------------------------- + +getIFaceInfos :: PackageId -> [String] -> Session -> IO [(ModIface, FilePath)] +getIFaceInfos pckg modules session = + case unpackPackageId pckg of + Nothing -> return [] + Just pid -> do + let isBase = pkgName pid == "base" + let ifaces = mapM (\ mn -> findAndReadIface empty + (if isBase + then mkBaseModule_ (mkModuleName mn) + else mkModule pckg + (mkModuleName mn)) + False) modules + hscEnv <- sessionHscEnv session + let gblEnv = IfGblEnv { if_rec_types = Nothing } + maybes <- initTcRnIf 'i' hscEnv gblEnv () ifaces + let res = catMaybes (map handleErr maybes) + return res + where + handleErr (M.Succeeded val) = Just val + handleErr (M.Failed mess) = Nothing + +getIFaceInfos2 :: [String] -> Session -> IO [(ModIface, FilePath)] +getIFaceInfos2 modules session = do + let ifaces = mapM (\ mn -> findAndReadIface2 mn + (mkModule mainPackageId (mkModuleName mn))) modules + hscEnv <- sessionHscEnv session + let gblEnv = IfGblEnv { if_rec_types = Nothing } + maybes <- initTcRnIf 'i' hscEnv gblEnv () ifaces + let res = catMaybes (map handleErr maybes) + return res + where + handleErr (M.Succeeded val) = Just val + handleErr (M.Failed mess) = Nothing + +findAndReadIface2 :: String -> Module -> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath)) +findAndReadIface2 doc mod = do + hsc_env <- getTopEnv + mb_found <- ioToIOEnv (findExactModule hsc_env mod) + case mb_found of + Found loc mod -> do + let file_path = ml_hi_file loc + read_result <- readIface mod file_path False + case read_result of + Failed _ -> returnM (Failed (text $ "can't read iface " ++ + doc ++ " at " ++ file_path)) + Succeeded iface + | mi_module iface /= mod + -> return (Failed (text $ "read but not equal" ++ doc)) + | otherwise + -> returnM (Succeeded (iface, file_path)) + _ -> return (Failed (text $ "can't locate " ++ doc)) + +------------------------------------------------------------------------- + +extractInfo :: ([(ModIface, FilePath)],[(ModIface, FilePath)],PackageIdentifier, + [PackageIdentifier]) -> PackageDescr +extractInfo (ifacesExp,ifacesHid,pi,depends) = + let hiddenDescrs = foldr (extractExportedDescrH pi) Map.empty (map fst ifacesHid) + mods = --trace ("\nhidden: " ++ show (Map.keysSet hiddenDescrs)) + map (extractExportedDescrR pi hiddenDescrs) (map fst ifacesExp) + in PackageDescr { + packagePD = pi + , exposedModulesPD = mods + , buildDependsPD = depends + , mbSourcePathPD = Nothing} + +extractExportedDescrH :: PackageIdentifier -> ModIface -> SymbolTable -> SymbolTable +extractExportedDescrH pid iface amap = + let exportedNames = Set.fromList + $ map occNameString + $ concatMap availNames + $ concatMap snd (mi_exports iface) + exportedDecls = filter (\ ifdecl -> (occNameString $ ifName ifdecl) + `Set.member` exportedNames) + (map snd (mi_decls iface)) + in foldr (extractIdentifierDescr' pid []) amap exportedDecls + +extractExportedDescrR :: PackageIdentifier + -> SymbolTable + -> ModIface + -> ModuleDescr +extractExportedDescrR pid hidden iface = + let mid = moduleNameString $moduleName (mi_module iface) + exportedNames = Set.fromList + $map occNameString + $concatMap availNames + $concatMap snd (mi_exports iface) + exportedDecls = filter (\ ifdecl -> (occNameString $ifName ifdecl) + `Set.member` exportedNames) + (map snd (mi_decls iface)) + ownDecls = concatMap (extractIdentifierDescr pid [mid]) exportedDecls +-- otherDecls = exportedNames `Set.difference` (Map.keysSet mapWithOwnDecls) +-- reexported = Map.map (\v -> map (\id -> id{moduleIdID = (PM pid mid)}) v) +-- {--: [moduleIdID id]--} +-- $Map.filterWithKey (\k _ -> k `Set.member` otherDecls) +-- hidden + inst = concatMap (extractInstances (PM pid mid)) (mi_insts iface) + uses = Map.fromList $ map extractUsages (mi_usages iface) + in ModuleDescr { + moduleIdMD = PM pid mid + , exportedNamesMD = exportedNames + , mbSourcePathMD = Nothing + , usagesMD = uses + , idDescriptionsMD = ownDecls ++ inst} + +extractIdentifierDescr' :: PackageIdentifier -> [ModuleIdentifier] -> IfaceDecl -> + SymbolTable -> SymbolTable +extractIdentifierDescr' pid mods ifDecl amap = + let descrs = extractIdentifierDescr pid mods ifDecl + in foldr addToMap amap descrs + where + addToMap :: IdentifierDescr -> SymbolTable -> SymbolTable + addToMap iddescr amap = + let allIds = identifierID iddescr : (constructorsID iddescr + ++ fieldsID iddescr + ++ classOpsID iddescr) + in foldl (\ st id -> Map.insertWith (++) id [iddescr] st) amap allIds + +extractIdentifierDescr :: PackageIdentifier -> [ModuleIdentifier] -> IfaceDecl + -> [IdentifierDescr] +extractIdentifierDescr package modules decl + = if null modules + then [] + else case decl of + (IfaceId _ _ _ ) + -> [SimpleDescr{ + identifierID = unpackFS $occNameFS (ifName decl) + , typeInfoID = BS.pack $ filterExtras $ showSDocUnqual $ppr decl + , identifierTypeID = FunctionS + , moduleIdID = PM package (last modules) + , mbLocation = Nothing + , mbComment = Nothing + }] + (IfaceData _ _ _ ifCons _ _ _ _) + -> case ifCons of + IfDataTyCon _ + -> [DataDescr{ + identifierID = unpackFS $occNameFS (ifName decl) + , typeInfoID = BS.pack $ filterExtras + $ showSDocUnqual $ppr decl + , moduleIdID = PM package (last modules) + , constructorsID = map extractConstructorName + (visibleIfConDecls ifCons) + , fieldsID = concatMap extractFieldNames + (visibleIfConDecls ifCons) + , mbLocation = Nothing + , mbComment = Nothing + }] + other -> [SimpleDescr{ + identifierID = unpackFS $occNameFS (ifName decl) + , typeInfoID = BS.pack $ filterExtras + $ showSDocUnqual $ppr decl + , identifierTypeID = case other of + IfNewTyCon _ -> NewtypeS + IfAbstractTyCon -> AbstractDataS + IfOpenDataTyCon -> OpenDataS + _ -> throwIDE + "Impossible" + , moduleIdID = PM package (last modules) + , mbLocation = Nothing + , mbComment = Nothing + }] + (IfaceClass _ _ _ _ _ ifSigs _ ) + -> [ClassDescr{ + identifierID = unpackFS $occNameFS (ifName decl) + , typeInfoID = BS.pack $ filterExtras + $ showSDocUnqual $ppr decl + , moduleIdID = PM package (last modules) + , classOpsID = map (extractClassOpName) ifSigs + , mbLocation = Nothing + , mbComment = Nothing + }] + (IfaceSyn _ _ _ _ _ ) + -> [SimpleDescr{ + identifierID = unpackFS $occNameFS (ifName decl) + , typeInfoID = BS.pack $ filterExtras + $ showSDocUnqual $ppr decl + , identifierTypeID = TypeS + , moduleIdID = PM package (last modules) + , mbLocation = Nothing + , mbComment = Nothing + }] + (IfaceForeign _ _) + -> [SimpleDescr{ + identifierID = unpackFS $occNameFS (ifName decl) + , typeInfoID = BS.pack $ filterExtras + $ showSDocUnqual $ppr decl + , identifierTypeID = ForeignS + , moduleIdID = PM package (last modules) + , mbLocation = Nothing + , mbComment = Nothing + }] + +extractConstructorName :: IfaceConDecl -> Symbol +extractConstructorName decl = unpackFS $occNameFS (ifConOcc decl) + +extractFieldNames :: IfaceConDecl -> [Symbol] +extractFieldNames decl = map (extractFieldNames') (ifConFields decl) + +extractFieldNames' :: OccName -> Symbol +extractFieldNames' occName = unpackFS $occNameFS occName + +extractClassOpName :: IfaceClassOp -> Symbol +extractClassOpName (IfaceClassOp occName _ _) = unpackFS $occNameFS occName + +extractInstances :: PackModule -> IfaceInst -> [IdentifierDescr] +extractInstances pm ifaceInst = + let className = showSDocUnqual $ ppr $ ifInstCls ifaceInst + dataNames = map (\iftc -> showSDocUnqual $ ppr iftc) + $ map fromJust + $ filter isJust + $ ifInstTys ifaceInst + in [InstanceDescr + { identifierID = className + , binds = dataNames + , moduleIdID = pm + , mbLocation = Nothing + , mbComment = Nothing}] + +extractUsages :: Usage -> (ModuleIdentifier, Set Symbol) +extractUsages usage = + let name = (showSDoc . ppr) $ usg_name usage + ids = map (showSDocUnqual . ppr . fst) $ usg_entities usage + in (name, Set.fromList ids) + +filterExtras, filterExtras' :: String -> String +filterExtras ('{':'-':r) = filterExtras' r +filterExtras ('R':'e':'c':'F':'l':'a':'g':r) + = filterExtras (skipNextWord r) +filterExtras ('G':'e':'n':'e':'r':'i':'c':'s':':':r) + = filterExtras (skipNextWord r) +filterExtras ('F':'a':'m':'i':'l':'y':'I':'n':'s':'t':'a':'n':'c':'e':':':r) + = filterExtras (skipNextWord r) +filterExtras (c:r) = c : filterExtras r +filterExtras [] = [] + +filterExtras' ('-':'}':r) = filterExtras r +filterExtras' (_:r) = filterExtras' r +filterExtras' [] = [] + +skipNextWord, skipNextWord' :: String -> String +skipNextWord (a:r) + | isSpace a = skipNextWord r + | otherwise = skipNextWord' r +skipNextWord [] = [] + +skipNextWord'(a:r) + | a == '\n' = r + | isSpace a = a:r + | otherwise = skipNextWord' r +skipNextWord' [] = [] + +writeExtracted :: FilePath -> Bool -> PackageDescr -> IO () +writeExtracted dirPath writeAscii pd = do + let filePath = dirPath showPackageId (packagePD pd) ++ ".pack" + if writeAscii + then writeFile (filePath ++ "dpg") (show pd) + else encodeFile filePath pd + +-- --------------------------------------------------------------------- +-- The (mothers) little helpers +-- + +getInstalledPackageInfos :: Session -> IO [DP.InstalledPackageInfo] +getInstalledPackageInfos session = do + dflags1 <- getSessionDynFlags session + pkgInfos <- case pkgDatabase dflags1 of + Nothing -> return [] + Just fm -> return (eltsUFM fm) + return pkgInfos + +asDPid :: PackageIdentifier -> DP.PackageIdentifier +asDPid (PackageIdentifier name version) = DP.PackageIdentifier name version + +fromDPid :: DP.PackageIdentifier -> PackageIdentifier +fromDPid (DP.PackageIdentifier name version) = PackageIdentifier name version + +findFittingPackages :: Session -> [Dependency] -> IO [PackageIdentifier] +findFittingPackages session dependencyList = do + knownPackages <- getInstalledPackageInfos session + let packages = map (fromDPid . DP.package) knownPackages + return (concatMap (fittingKnown packages) dependencyList) + where + fittingKnown packages (Dependency dname versionRange) = + let filtered = filter (\ (PackageIdentifier name version) -> + name == dname && withinRange version versionRange) + packages + in if length filtered > 1 + then [maximumBy (\a b -> compare (pkgVersion a) (pkgVersion b)) filtered] + else filtered + +findFittingPackagesDP :: Session -> [Dependency] -> IO [PackageIdentifier] +findFittingPackagesDP session dependencyList = do + fp <- (findFittingPackages session dependencyList) + return fp + +-- --------------------------------------------------------------------- +-- Binary Instances for linear storage +-- + +instance Binary PackModule where + put (PM pack' modu') + = do put pack' + put modu' + get = do pack' <- get + modu' <- get + return (PM pack' modu') + +instance Binary PackageIdentifier where + put (PackageIdentifier name' version') + = do put name' + put version' + get = do name' <- get + version' <- get + return (PackageIdentifier name' version') + +instance Binary Version where + put (Version branch' tags') + = do put branch' + put tags' + get = do branch' <- get + tags' <- get + return (Version branch' tags') + + +instance Binary PackageDescr where + put (PackageDescr packagePD' exposedModulesPD' buildDependsPD' mbSourcePathPD') + = do put packagePD' + put exposedModulesPD' + put buildDependsPD' + put mbSourcePathPD' + get = do packagePD' <- get + exposedModulesPD' <- get + buildDependsPD' <- get + mbSourcePathPD' <- get + return (PackageDescr packagePD' exposedModulesPD' buildDependsPD' + mbSourcePathPD') + +instance Binary ModuleDescr where + put (ModuleDescr moduleIdMD' exportedNamesMD' mbSourcePathMD' usagesMD' + idDescriptionsMD') + = do put moduleIdMD' + put exportedNamesMD' + put mbSourcePathMD' + put usagesMD' + put idDescriptionsMD' + get = do moduleIdMD' <- get + exportedNamesMD' <- get + mbSourcePathMD' <- get + usagesMD' <- get + idDescriptionsMD' <- get + return (ModuleDescr moduleIdMD' exportedNamesMD' mbSourcePathMD' + usagesMD' idDescriptionsMD') + +instance Binary IdentifierDescr where + put (SimpleDescr identifierID' identifierTypeID' typeInfoID' moduleIdID' + mbLocation' mbComment') + = do put (1::Int) + put identifierID' + put identifierTypeID' + put typeInfoID' + put moduleIdID' + put mbLocation' + put mbComment' + put (DataDescr identifierID' typeInfoID' moduleIdID' + constructorsID' fieldsID' mbLocation' mbComment') + = do put (2::Int) + put identifierID' + put typeInfoID' + put moduleIdID' + put constructorsID' + put fieldsID' + put mbLocation' + put mbComment' + put (ClassDescr identifierID' typeInfoID' moduleIdID' + classOpsID' mbLocation' mbComment') + = do put (3::Int) + put identifierID' + put typeInfoID' + put moduleIdID' + put classOpsID' + put mbLocation' + put mbComment' + put (InstanceDescr identifierID' classID' moduleIdID' mbLocation' mbComment') + = do put (4::Int) + put identifierID' + put classID' + put moduleIdID' + put mbLocation' + put mbComment' + get = do (typeHint :: Int) <- get + case typeHint of + 1 -> do + identifierID' <- get + identifierTypeID' <- get + typeInfoID' <- get + moduleIdID' <- get + mbLocation' <- get + mbComment' <- get + return (SimpleDescr identifierID' identifierTypeID' typeInfoID' + moduleIdID' mbLocation' mbComment') + 2 -> do + identifierID' <- get + typeInfoID' <- get + moduleIdID' <- get + constructorsID' <- get + fieldsID' <- get + mbLocation' <- get + mbComment' <- get + return (DataDescr identifierID' typeInfoID' moduleIdID' + constructorsID' fieldsID' mbLocation' mbComment') + 3 -> do + identifierID' <- get + typeInfoID' <- get + moduleIdID' <- get + classOpsID' <- get + mbLocation' <- get + mbComment' <- get + return (ClassDescr identifierID' typeInfoID' moduleIdID' + classOpsID' mbLocation' mbComment') + 4 -> do + identifierID' <- get + classID' <- get + moduleIdID' <- get + mbLocation' <- get + mbComment' <- get + return (InstanceDescr identifierID' classID' moduleIdID' + mbLocation' mbComment') + _ -> throwIDE "Impossible in Binary IdentifierDescr get" + + +instance Binary IdTypeS where + put it = do put (fromEnum it) + get = do code <- get + return (toEnum code) + +instance Binary Location where + put (Location locationSLine' locationSCol' locationELine' locationECol') + = do put locationSLine' + put locationSCol' + put locationELine' + put locationECol' + get = do locationSLine' <- get + locationSCol' <- get + locationELine' <- get + locationECol' <- get + return (Location locationSLine' locationSCol' locationELine' locationECol') + + diff --git a/src/IDE/Metainfo/SourceCollector.hs b/src/IDE/Metainfo/SourceCollector.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Metainfo/SourceCollector.hs @@ -0,0 +1,580 @@ +----------------------------------------------------------------------------- +-- +-- Module : IDE.Metainfo.SourceCollector +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | This module collects information for packages with source available +-- +------------------------------------------------------------------------------- + +module IDE.Metainfo.SourceCollector ( + collectAllSources +, collectSources +, buildSourceForPackageDB +, sourceForPackage +, parseSourceForPackageDB +, getSourcesMap +) where + +import qualified Text.PrettyPrint.HughesPJ as PP +import qualified Data.Map as Map +import Data.Map (Map) +import Distribution.PackageDescription +import Distribution.Verbosity +import Text.ParserCombinators.Parsec +import qualified Text.ParserCombinators.Parsec.Token as P +import Text.ParserCombinators.Parsec.Language(emptyDef) +import System.Directory +import Control.Monad.State +import System.FilePath +import System.IO +import Data.List(nub,delete,sort) +import Distribution.Simple.PreProcess.Unlit +import Distribution.Simple.PreProcess(runSimplePreProcessor,ppCpp) +import Distribution.Simple.Program(defaultProgramConfiguration) +import Distribution.Compiler(CompilerFlavor(..)) +import Distribution.Simple.LocalBuildInfo(LocalBuildInfo(..)) +import Distribution.Simple.Configure(configure) +import Distribution.Simple.Setup(emptyConfigFlags) +import Data.Maybe(catMaybes) +import qualified Control.Exception as C +import qualified Data.ByteString.Char8 as BS + + +import GHC hiding (idType) +import SrcLoc +import RdrName +import OccName +import DynFlags +import PackageConfig hiding (exposedModules) +import StringBuffer +import Bag +import ErrUtils +import FastString +import Lexer hiding (lexer) +import Parser +import Outputable hiding (char) +import HscStats + +import IDE.Core.State +import IDE.Utils.File +import IDE.Preferences + +-- --------------------------------------------------------------------- +-- Function to map packages to file paths +-- + +getSourcesMap :: IO (Map PackageIdentifier [FilePath]) +getSourcesMap = do + mbSources <- parseSourceForPackageDB + case mbSources of + Just map -> do + return map + Nothing -> do + buildSourceForPackageDB + mbSources <- parseSourceForPackageDB + case mbSources of + Just map -> do + return map + Nothing -> throwIDE "can't build/open source for package file" + +sourceForPackage :: PackageIdentifier + -> (Map PackageIdentifier [FilePath]) + -> Maybe FilePath +sourceForPackage id map = + case id `Map.lookup` map of + Just (h:_) -> Just h + _ -> Nothing + +buildSourceForPackageDB :: IO () +buildSourceForPackageDB = do + prefsPath <- getConfigFilePathForLoad "Default.prefs" + prefs <- readPrefs prefsPath + let dirs = sourceDirectories prefs + cabalFiles <- mapM allCabalFiles dirs + fCabalFiles <- mapM canonicalizePath $ concat cabalFiles + packages <- mapM (\fp -> parseCabal fp) fCabalFiles + let pdToFiles = Map.fromListWith (++) (zip packages (map (\a -> [a]) fCabalFiles)) + filePath <- getConfigFilePathForSave "source_packages.txt" + writeFile filePath (PP.render (showSourceForPackageDB pdToFiles)) + +showSourceForPackageDB :: Map String [FilePath] -> PP.Doc +showSourceForPackageDB aMap = PP.vcat (map showIt (Map.toList aMap)) + where + showIt :: (String,[FilePath]) -> PP.Doc + showIt (pd,list) = (foldl (\l n -> l PP.$$ (PP.text $ show n)) label list) + PP.<> PP.char '\n' + where label = PP.text pd PP.<> PP.colon + +parseSourceForPackageDB :: IO (Maybe (Map PackageIdentifier [FilePath])) +parseSourceForPackageDB = do + filePath <- getConfigFilePathForLoad "source_packages.txt" + exists <- doesFileExist filePath + if exists + then do + res <- parseFromFile sourceForPackageParser filePath + case res of + Left pe -> do + sysMessage Normal $"Error reading source packages file " + ++ filePath ++ " " ++ show pe + return Nothing + Right r -> return (Just r) + else do + sysMessage Normal $"No source packages file found: " ++ filePath + return Nothing + +-- --------------------------------------------------------------------- +-- | Parser for Package DB +-- + +sourceForPackageParser :: CharParser () (Map PackageIdentifier [FilePath]) +sourceForPackageParser = do + whiteSpace + ls <- many onePackageParser + whiteSpace + eof + return (Map.fromList (catMaybes ls)) + "sourceForPackageParser" + +onePackageParser :: CharParser () (Maybe (PackageIdentifier,[FilePath])) +onePackageParser = do + mbPd <- packageDescriptionParser + filePaths <- many filePathParser + case mbPd of + Nothing -> return Nothing + Just pd -> return (Just (pd,filePaths)) + "onePackageParser" + +packageDescriptionParser :: CharParser () (Maybe PackageIdentifier) +packageDescriptionParser = try (do + whiteSpace + str <- many (noneOf ":") + char ':' + return (toPackageIdentifier str)) + "packageDescriptionParser" + +filePathParser :: CharParser () FilePath +filePathParser = try (do + whiteSpace + char '"' + str <- many (noneOf ['"']) + char '"' + return (str)) + "filePathParser" + +-- --------------------------------------------------------------------- +-- | Parser for the package name from a cabal file +-- + +cabalStyle :: P.LanguageDef st +cabalStyle = emptyDef + { P.commentStart = "{-" + , P.commentEnd = "-}" + , P.commentLine = "--" + } + +lexer = P.makeTokenParser cabalStyle +whiteSpace = P.whiteSpace lexer +symbol = P.symbol lexer + +parseCabal :: FilePath -> IO String +parseCabal fn = do + putStrLn $ "Now parsing minimal " ++ fn + res <- parseFromFile cabalMinimalParser fn + case res of + Left pe -> do + putStrLn "before throw" + throwIDE $"Error reading cabal file " ++ show fn ++ " " ++ show pe + Right r -> do + sysMessage Normal r + return r + +cabalMinimalParser :: CharParser () String +cabalMinimalParser = do + r1 <- cabalMinimalP + r2 <- cabalMinimalP + case r1 of + Left v -> do + case r2 of + Right n -> return (n ++ "-" ++ v) + Left _ -> throwIDE "Illegal cabal" + Right n -> do + case r2 of + Left v -> return (n ++ "-" ++ v) + Right _ -> throwIDE "Illegal cabal" + +cabalMinimalP :: CharParser () (Either String String) +cabalMinimalP = + do try $(symbol "name:" <|> symbol "Name:") + whiteSpace + name <- (many $noneOf " \n") + (many $noneOf "\n") + char '\n' + return (Right name) + <|> do + try $(symbol "version:" <|> symbol "Version:") + whiteSpace + version <- (many $noneOf " \n") + (many $noneOf "\n") + char '\n' + return (Left version) + <|> do + many $noneOf "\n" + char '\n' + cabalMinimalP + "cabal minimal" + +-- --------------------------------------------------------------------- +-- Functions to collect infos from the sources +-- + +-- --------------------------------------------------------------------- +-- | Collect infos from sources for a list of packages +-- +collectAllSources :: Session + -> Map PackageIdentifier [FilePath] + -> [PackageDescr] + -> IO ([PackageDescr],Int) +collectAllSources session sourceMap pdescrs = + foldM (\ (pdescrs, failureNum) pdescr -> do + (pdescr, num) <- collectSources session sourceMap pdescr + return (pdescr:pdescrs,failureNum + num)) + ([],0) pdescrs + +-- --------------------------------------------------------------------- +-- | Collect infos from sources for one package +-- +collectSources :: Session + -> Map PackageIdentifier [FilePath] + -> PackageDescr + -> IO (PackageDescr,Int) +collectSources session sourceMap pdescr = do + putStrLn $ "Now collecting sources for " ++ show (packagePD pdescr) + case sourceForPackage (packagePD pdescr) sourceMap of + Nothing -> do + sysMessage Normal $ "No source for package " ++ showPackageId (packagePD pdescr) + return (pdescr,0) + Just cabalPath -> C.catch (do + let basePath = takeDirectory cabalPath + dflags0 <- getSessionDynFlags session + setSessionDynFlags session dflags0 + { topDir = basePath + , ghcMode = CompManager + } + dflags1 <- getSessionDynFlags session + let flags = ["-fglasgow-exts",("-I" ++ basePath "include"),"-haddock"] + (dflags2,_) <- parseDynamicFlags dflags1 flags + + setSessionDynFlags session dflags2 + + genPkgDescr <- readPackageDescription silent cabalPath + let pkgDescr = flattenPackageDescription genPkgDescr + localBuildInfo <- configure (Left genPkgDescr, emptyHookedBuildInfo) + (emptyConfigFlags defaultProgramConfiguration) + --let allModules = libModules pd ++ exeModules pd + let exposedMods = exposedModulesPD pdescr + let buildPaths = nub $ ("dist" "build" "autogen") : + (concatMap hsSourceDirs $ allBuildInfo pkgDescr) + let basePath = normalise $ (takeDirectory cabalPath) + sourceFiles <- mapM (findSourceFile + (map (\p -> basePath p) buildPaths) + ["hs","lhs"]) + (map (modu . moduleIdMD) exposedMods) + (newModDescrs,failureCount) + <- foldM (collectSourcesForModule session genPkgDescr + localBuildInfo) ([],0) + (zip (exposedModulesPD pdescr) sourceFiles) + let nPackDescr = pdescr{mbSourcePathPD = Just cabalPath, + exposedModulesPD = newModDescrs} + return (nPackDescr,failureCount)) + (\e -> do sysMessage Normal $ "source collector throwIDE " ++ show e ++ " in " ++ + showPackageId (packagePD pdescr) + return (pdescr,length $ exposedModulesPD pdescr)) + +-- --------------------------------------------------------------------- +-- | Collect infos from sources for one module +-- +collectSourcesForModule :: Session + -> GenericPackageDescription + -> LocalBuildInfo + -> ([ModuleDescr],Int) + -> (ModuleDescr, Maybe FilePath) + -> IO ([ModuleDescr],Int) +collectSourcesForModule session pkgDescr localBuildInfo (moduleDescrs,failureCount) + (moduleDescr,mbfp) = + case mbfp of + Nothing -> do + sysMessage Normal $ "No source for module " ++ (modu $ moduleIdMD moduleDescr) + return(moduleDescr : moduleDescrs, failureCount+1) + Just fp -> do + str <- preprocess fp pkgDescr localBuildInfo + stringBuffer <- stringToStringBuffer str + dynFlags <- getSessionDynFlags session + parseResult <- myParseModule dynFlags fp (Just stringBuffer) + let newModD = moduleDescr{mbSourcePathMD = mbfp} + case parseResult of + Right (L _ (HsModule _ _ _ decls _ _ _ _)) -> do + let map' = convertToMap (idDescriptionsMD newModD) + let commentedDecls = addComments (filterSignatures decls) + let (descrs,restMap) = foldl collectParseInfoForDecl ([],map') + commentedDecls + let newModD' = newModD{ + idDescriptionsMD = reverse descrs ++ concat (Map.elems restMap)} + return(newModD' : moduleDescrs, failureCount) + Left errMsg -> do + sysMessage Normal $ "Failed to parse " ++ fp + printBagOfErrors defaultDynFlags (unitBag errMsg) + return (newModD : moduleDescrs, failureCount+1) + where + convertToMap :: [IdentifierDescr] -> Map Symbol [IdentifierDescr] + convertToMap list = + foldl (\ st idDescr -> Map.insertWith (++) (identifierID idDescr) [idDescr] st) + Map.empty list + convertFromMap :: Map Symbol [IdentifierDescr] -> [IdentifierDescr] + convertFromMap = concat . Map.elems + +filterSignatures :: [LHsDecl RdrName] -> [LHsDecl RdrName] +filterSignatures declList = filter filterSignature declList + where + filterSignature (L srcDecl (SigD _)) = False + filterSignature _ = True + +addComments :: [LHsDecl RdrName] -> [(Maybe (LHsDecl RdrName), Maybe String)] +addComments declList = reverse $ snd $ foldl addComment (Nothing,[]) declList + where + addComment :: (Maybe String,[(Maybe (LHsDecl RdrName),Maybe String)]) + -> LHsDecl RdrName + -> (Maybe String,[(Maybe (LHsDecl RdrName),Maybe String)]) + addComment (maybeComment,((Just decl,Nothing):r)) (L srcDecl (DocD (DocCommentPrev doc))) = + (Nothing,((Just decl,Just (printHsDoc doc)):r)) + addComment other (L srcDecl (DocD (DocCommentPrev doc))) = + other + addComment (maybeComment,resultList) (L srcDecl (DocD (DocCommentNext doc))) = + (Just (printHsDoc doc),resultList) + addComment (maybeComment,resultList) (L srcDecl (DocD (DocGroup i doc))) = + (Nothing,(((Nothing,Just (printHsDoc doc)): resultList))) + addComment (maybeComment,resultList) (L srcDecl (DocD (DocCommentNamed str doc))) = + (Nothing,resultList) + addComment (Nothing,resultList) decl = + (Nothing,(Just decl,Nothing):resultList) + addComment (Just comment,resultList) decl = + (Nothing,(Just decl,Just comment):resultList) + +collectParseInfoForDecl :: ([IdentifierDescr],SymbolTable) + -> (Maybe (LHsDecl RdrName),Maybe String) + -> ([IdentifierDescr],SymbolTable) +collectParseInfoForDecl (l,st) (Just (L loc _),_) | not (isGoodSrcSpan loc) = (l,st) +collectParseInfoForDecl (l,st) ((Just (L loc (ValD (FunBind lid _ _ _ _ _)))), mbComment') + = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Function] [] +collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (TyData _ _ lid _ _ _ _ _)))), mbComment') + = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Data] [] +collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (TyFamily _ lid _ _)))), mbComment') + = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [] [] +collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (TySynonym lid _ _ _)))), mbComment') + = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Type] [] +collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (ClassDecl _ lid _ _ _ _ _ _ )))), mbComment') + = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Class] [] +collectParseInfoForDecl (l,st) ((Just (L loc (InstD (InstDecl lid binds sigs cldecl)))), mbComment') + = case unLoc lid of + HsForAllTy _ _ _ e -> + case unLoc e of + HsPredTy p -> + case p of + HsClassP n types + -> --trace ("name: " ++ unpackFS (occNameFS (rdrNameOcc n)) ++ "\n" ++ + --"binds : " ++ showSDocUnqual (ppr binds) ++ "\n" ++ + --"sigs : " ++ showSDocUnqual (ppr sigs) ++ "\n" ++ + --"cldecl : " ++ showSDocUnqual (ppr cldecl) ++ "\n" ++ + -- "types : " ++ showSDocUnqual (ppr types)) $ + addLocationAndComment (l,st) n loc mbComment' [Instance] + (map (\t -> analyse (unLoc t)) types) + _ -> trace ("lid3:Other") (l,st) + _ -> trace "lid2:Other" (l,st) + _ -> trace "lid:Other" (l,st) + where + analyse (HsTyVar n) = unpackFS (occNameFS (rdrNameOcc n)) + analyse (HsForAllTy n _ _ _) = trace "lid5:For all" "" + analyse _ = trace "lid5:Other" "" +collectParseInfoForDecl (l,st) (Just decl,mbComment') + = trace (declTypeToString (unLoc decl) ++ "--" ++ (showSDocUnqual $ppr decl)) (l,st) +collectParseInfoForDecl (l,st) (Nothing, mbComment') = + trace ("Found comment " ++ show mbComment') (l,st) + + +addLocationAndComment :: ([IdentifierDescr],SymbolTable) + -> RdrName + -> SrcSpan + -> Maybe String + -> [IdType] + -> [String] + -> ([IdentifierDescr],SymbolTable) +addLocationAndComment (l,st) lid srcSpan mbComment' types insts = + let occ = rdrNameOcc lid + name = unpackFS (occNameFS occ) + mbItems = Map.lookup name st + (mbItem,nst)= case mbItems of + Nothing -> (Nothing,st) + Just [i] -> (Just i, Map.delete name st) + Just list -> + case filter (\i -> matches i types insts) list of + [] -> (Nothing,st) + l' -> (Just (head l'), + Map.adjust (\li -> delete (head l') li) + name st) + in case mbItem of + Nothing -> (l,st) + Just identDescr -> (identDescr{ + mbLocation = Just (srcSpanToLocation srcSpan), + mbComment = case mbComment' of + Nothing -> Nothing + Just s -> Just (BS.pack s)} + : l, nst) + + where + matches :: IdentifierDescr -> [IdType] -> [String] -> Bool + matches idDescr idTypes inst = + case idType idDescr of + Instance -> + --trace ("instances " ++ show (sort (binds idDescr)) ++ " -- ?= -- " ++ show (sort inst)) $ + elem Instance idTypes && sort (binds idDescr) == sort inst + other -> elem other idTypes + +declTypeToString :: Show alpha => HsDecl alpha -> String +declTypeToString (TyClD _) = "TyClD" +declTypeToString (InstD _) = "InstD" +declTypeToString (DerivD _)= "DerivD" +declTypeToString (ValD _) = "ValD" +declTypeToString (SigD _) = "SigD" +declTypeToString (DefD _) = "DefD" +declTypeToString (ForD _) = "ForD" +declTypeToString (DeprecD _)= "DeprecD" +declTypeToString (RuleD _) = "RuleD" +declTypeToString (SpliceD _) = "SpliceD" +declTypeToString (DocD v) = "DocD " ++ show v + + +srcSpanToLocation :: SrcSpan -> Location +srcSpanToLocation span | not (isGoodSrcSpan span) + = throwIDE "srcSpanToLocation: unhelpful span" +srcSpanToLocation span + = Location (srcSpanStartLine span) (srcSpanStartCol span) + (srcSpanEndLine span) (srcSpanEndCol span) + +printHsDoc :: Show alpha => HsDoc alpha -> String +printHsDoc DocEmpty = "" +printHsDoc (DocAppend l r) = printHsDoc l ++ " " ++ printHsDoc r +printHsDoc (DocString str) = str +printHsDoc (DocParagraph d) = printHsDoc d ++ "\n" +printHsDoc (DocIdentifier l) = concatMap show l +printHsDoc (DocModule str) = "Module " ++ str +printHsDoc (DocEmphasis doc) = printHsDoc doc +printHsDoc (DocMonospaced doc) = printHsDoc doc +printHsDoc (DocUnorderedList l) = concatMap printHsDoc l +printHsDoc (DocOrderedList l) = concatMap printHsDoc l +printHsDoc (DocDefList li) = concatMap (\(l,r) -> printHsDoc l ++ " " ++ + printHsDoc r) li +printHsDoc (DocCodeBlock doc) = printHsDoc doc +printHsDoc (DocURL str) = str +printHsDoc (DocAName str) = str +printHsDoc (DocPic _) = "" + + +instance Show RdrName where + show = unpackFS . occNameFS . rdrNameOcc + +instance Show alpha => Show (DocDecl alpha) where + show (DocCommentNext doc) = "DocCommentNext " ++ show doc + show (DocCommentPrev doc) = "DocCommentPrev " ++ show doc + show (DocCommentNamed str doc) = "DocCommentNamed" ++ " " ++ str ++ " " ++ show doc + show (DocGroup i doc) = "DocGroup" ++ " " ++ show i ++ " " ++ show doc + +--instance Show alpha => Show (HsDoc alpha) where +-- show d = printHsDoc d + + + --------------------------------------------------------------------- +-- | Simple preprocessing + +preprocess :: FilePath -> GenericPackageDescription -> LocalBuildInfo -> IO String +preprocess fp pkgDescr localBuildInfo = + let aBuildInfo = head (allBuildInfo (flattenPackageDescription pkgDescr)) + needCpp = elem "-cpp" (hcOptions GHC (options aBuildInfo)) + in C.catch (do + str' <- if True + then do + tempFileName <- getConfigFilePathForSave "Temp.hspp" + isItTheir <- doesFileExist tempFileName + when isItTheir $ + removeFile tempFileName +-- (_, conf') <- requireProgram normal ghcProgram +-- (orLaterVersion (Version [6,2] [])) +-- defaultProgramConfiguration + +-- localBuildInfo' <- localBuildInfo pkgDescr conf' + + runSimplePreProcessor (ppCpp aBuildInfo localBuildInfo) + fp tempFileName normal + isItTheir <- doesFileExist tempFileName + if isItTheir + then do + str <- readFile tempFileName + return str + else do + sysMessage Normal $ "Failed to preprocess " ++ fp + str <- readFile fp + return str + else do + str <- readFile fp + return str + let str2 = if takeExtension fp == ".lhs" + then unlit fp str' + else str' + return str2) + (\e -> do sysMessage Normal $ "preprocess throwIDE " ++ show e ++ " in " ++ fp + str <- readFile fp + return str) + + --------------------------------------------------------------------- +-- | Parser function copied here, because it is not exported + +myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer + -> IO (Either ErrMsg (Located (HsModule RdrName))) +myParseModule dflags src_filename maybe_src_buf + = -------------------------- Parser ---------------- + showPass dflags "Parser" >> + {-# SCC "Parser" #-} do + + -- sometimes we already have the buffer in memory, perhaps + -- because we needed to parse the imports out of it, or get the + -- module name. + buf <- case maybe_src_buf of + Just b -> return b + Nothing -> hGetStringBuffer src_filename + + let loc = mkSrcLoc (mkFastString src_filename) 1 0 + + case unP parseModule (mkPState buf loc dflags) of { + + PFailed span err -> return (Left (mkPlainErrMsg span err)); + + POk pst rdr_module -> do { + + let {ms = getMessages pst}; + printErrorsAndWarnings dflags ms; + -- when (errorsFound dflags ms) $ exitWith (ExitFailure 1); + + dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; + + dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" + (ppSourceStats False rdr_module) ; + + return (Right rdr_module) + -- ToDo: free the string buffer later. + }} + + diff --git a/src/IDE/ModulesPane.hs b/src/IDE/ModulesPane.hs new file mode 100644 --- /dev/null +++ b/src/IDE/ModulesPane.hs @@ -0,0 +1,792 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.ModulesPane +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | The pane of ide where modules are presented in tree form with their +-- packages and exports +-- +------------------------------------------------------------------------------- + +module IDE.ModulesPane ( + showModules +, selectIdentifier +, reloadKeepSelection +) where + +import Graphics.UI.Gtk hiding (get) +import Graphics.UI.Gtk.ModelView as New +import Data.Maybe +import Control.Monad.Reader +import qualified Data.Map as Map +import Data.Tree +import Data.List +import Distribution.Package +import Distribution.Version +import Data.Char (toLower) + + +import IDE.Core.State +import IDE.Framework.ViewFrame +import IDE.InfoPane +import IDE.SourceEditor + +instance IDEObject IDEModules + +instance Pane IDEModules + where + primPaneName _ = "Modules" + getAddedIndex _ = 0 + getTopWidget = castToWidget . outer + paneId b = "*Modules" + makeActive p = activatePane p (BufConnections[][] []) + close pane = do + (panePath,_) <- guiPropertiesFromName (paneName pane) + nb <- getNotebook panePath + mbI <- lift $notebookPageNum nb (getTopWidget pane) + case mbI of + Nothing -> throwIDE "Pane>IDEModules: notebook page not found: unexpected" + Just i -> do + deactivatePaneIfActive pane + lift $notebookRemovePage nb i + removePaneAdmin pane + +instance RecoverablePane IDEModules ModulesState where + saveState p = do + (IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) <- getModules + sc <- getScope + mbModules <- getPane ModulesCasting + case mbModules of + Nothing -> return Nothing + Just p -> lift $ do + i <- panedGetPosition (paned p) + mbTreeSelection <- getSelectionTree treeView treeStore + mbFacetSelection <- getSelectionFacet facetView facetStore + let mbs = (case mbTreeSelection of + Nothing -> Nothing + Just (_,[]) -> Nothing + Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md), + case mbFacetSelection of + Nothing -> Nothing + Just fw -> Just (symbolFromFacetWrapper fw)) + return (Just (StateC (ModulesState i sc mbs))) + recoverState pp (ModulesState i sc@(scope,useBlacklist) se) = do + nb <- getNotebook pp + initModules pp nb + mod@(IDEModules _ _ treeView treeStore facetView facetStore lb pb wb blb) + <- getModules + case scope of + Local -> lift $ toggleButtonSetActive lb True + Package -> lift $ toggleButtonSetActive pb True + World -> lift $ toggleButtonSetActive wb True + lift $ toggleButtonSetActive blb useBlacklist + lift $ panedSetPosition (paned mod) i + fillModulesList sc + selectNames se + +selectIdentifier :: IdentifierDescr -> IDEAction +selectIdentifier idDescr = selectIdentifier' (modu $ moduleIdID idDescr) (identifierID idDescr) + + +selectIdentifier' :: ModuleIdentifier -> Symbol -> IDEAction +selectIdentifier' moduleName symbol = + let nameArray = breakAtDots [] moduleName + in do + mods@(IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) <- getModules + tree <- lift $ New.treeStoreGetTree treeStore [] + case treePathFromNameArray tree nameArray [] of + Just treePath -> lift $ do + New.treeViewExpandToPath treeView treePath + sel <- New.treeViewGetSelection treeView + New.treeSelectionSelectPath sel treePath + col <- New.treeViewGetColumn treeView 0 + New.treeViewScrollToCell treeView treePath (fromJust col) (Just (0.3,0.3)) + facetTree <- New.treeStoreGetTree facetStore [] + selF <- New.treeViewGetSelection facetView + case findPathFor symbol facetTree of + Nothing -> sysMessage Normal "no path found" + Just path -> do + New.treeSelectionSelectPath selF path + col <- New.treeViewGetColumn facetView 0 + New.treeViewScrollToCell facetView path (fromJust col) (Just (0.3,0.3)) + bringPaneToFront mods + Nothing -> return () + +findPathFor :: Symbol -> Tree FacetWrapper -> Maybe TreePath +findPathFor symbol (Node _ forest) = + foldr ( \i mbTreePath -> findPathFor' [i] (forest !! i) mbTreePath) + Nothing [0 .. ((length forest) - 1)] + where + findPathFor' :: TreePath -> Tree FacetWrapper -> Maybe TreePath -> Maybe TreePath + findPathFor' _ node (Just p) = Just p + findPathFor' path (Node wrap sub) Nothing = + if identifierID (facetIdDescr wrap) == symbol + then Just (reverse path) + else + foldr ( \i mbTreePath -> findPathFor' (i:path) (sub !! i) mbTreePath) + Nothing [0 .. ((length sub) - 1)] + + + +treePathFromNameArray :: ModTree -> [String] -> [Int] -> Maybe [Int] +treePathFromNameArray tree [] accu = Just (reverse accu) +treePathFromNameArray tree (h:t) accu = + let names = map (\t -> fst $ rootLabel t) (subForest tree) + mbIdx = elemIndex h names + in case mbIdx of + Nothing -> Nothing + Just i -> treePathFromNameArray (subForest tree !! i) t (i:accu) + +showModules :: IDEAction +showModules = do + sc <- getScope + fillModulesList sc + m <- getModules + lift $ bringPaneToFront m + +getModules :: IDEM IDEModules +getModules = do + mbMod <- getPane ModulesCasting + case mbMod of + Nothing -> do + prefs <- readIDE prefs + layout <- readIDE layout + let pp = getStandardPanePath (modulesPanePath prefs) layout + nb <- getNotebook pp + initModules pp nb + mbMod <- getPane ModulesCasting + case mbMod of + Nothing -> throwIDE "Can't init modules" + Just m -> return m + Just m -> return m + +initModules :: PanePath -> Notebook -> IDEAction +initModules panePath nb = do + ideR <- ask + panes <- readIDE panes + paneMap <- readIDE paneMap + prefs <- readIDE prefs + currentInfo <- readIDE currentInfo + (buf,cids) <- lift $ do + +-- Modules List + + let forest = case currentInfo of + Nothing -> [] + Just pair -> subForest (buildModulesTree pair) + treeStore <- New.treeStoreNew forest + treeView <- New.treeViewNew + New.treeViewSetModel treeView treeStore + New.treeViewSetEnableSearch treeView True + New.treeViewSetSearchColumn treeView 0 + New.treeViewSetSearchEqualFunc treeView (treeViewSearch treeView treeStore) + + --New.treeViewSetRulesHint treeView True + + renderer0 <- New.cellRendererPixbufNew + set renderer0 [ cellPixbufStockId := "ide_no_source" ] + + renderer <- New.cellRendererTextNew + col <- New.treeViewColumnNew + New.treeViewColumnSetTitle col "Modules" + New.treeViewColumnSetSizing col TreeViewColumnAutosize + New.treeViewColumnSetReorderable col True + New.treeViewAppendColumn treeView col + New.cellLayoutPackStart col renderer0 False + New.cellLayoutPackStart col renderer True + New.cellLayoutSetAttributes col renderer treeStore + $ \row -> [ New.cellText := fst row] + New.cellLayoutSetAttributes col renderer0 treeStore + $ \row -> [ + cellPixbufStockId := + if null (snd row) + then "" + else if isJust (mbSourcePathMD (fst (head (snd row)))) + then "ide_source" + else "ide_no_source"] + + renderer2 <- New.cellRendererTextNew + col2 <- New.treeViewColumnNew + New.treeViewColumnSetTitle col2 "Packages" + New.treeViewColumnSetSizing col2 TreeViewColumnAutosize + New.treeViewColumnSetReorderable col2 True + New.treeViewAppendColumn treeView col2 + New.cellLayoutPackStart col2 renderer2 True + New.cellLayoutSetAttributes col2 renderer2 treeStore + $ \row -> [ New.cellText := + concat + $ intersperse ", " + $ map (showPackageId . packagePD . snd) (snd row)] + +-- Facet view + + facetView <- New.treeViewNew + facetStore <- New.treeStoreNew [] + New.treeViewSetModel facetView facetStore + New.treeViewSetEnableSearch facetView True +-- New.treeViewSetSearchColumn facetView 0 +-- New.treeViewSetSearchEqualFunc facetView +-- (\ _ string iter -> do +-- [ind] <- New.treeModelGetPath facetStore iter +-- val <- New.listStoreGetValue facetStore ind +-- return (isInfixOf (map toLower string) (map toLower (fst val)))) + + renderer30 <- New.cellRendererPixbufNew + renderer31 <- New.cellRendererPixbufNew + renderer3 <- New.cellRendererTextNew + col <- New.treeViewColumnNew + New.treeViewColumnSetTitle col "Interface" + --New.treeViewColumnSetSizing col TreeViewColumnAutosize + New.treeViewAppendColumn facetView col + New.cellLayoutPackStart col renderer30 False + New.cellLayoutPackStart col renderer31 False + New.cellLayoutPackStart col renderer3 True + New.cellLayoutSetAttributes col renderer3 facetStore + $ \row -> [ New.cellText := facetTreeText row] + New.cellLayoutSetAttributes col renderer30 facetStore + $ \row -> [ + cellPixbufStockId := stockIdFromType (facetIdType row)] + New.cellLayoutSetAttributes col renderer31 facetStore + $ \row -> [ + cellPixbufStockId := if isJust (mbLocation(facetIdDescr row)) + then "ide_source" + else ""] + New.treeViewSetHeadersVisible treeView True + + pane' <- hPanedNew + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw treeView + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + sw2 <- scrolledWindowNew Nothing Nothing + containerAdd sw2 facetView + scrolledWindowSetPolicy sw2 PolicyAutomatic PolicyAutomatic + panedAdd1 pane' sw + panedAdd2 pane' sw2 + (x,y) <- widgetGetSize nb + panedSetPosition pane' (x `quot` 2) + box <- hBoxNew True 2 + rb1 <- radioButtonNewWithLabel "Local" + rb2 <- radioButtonNewWithLabelFromWidget rb1 "Package" + rb3 <- radioButtonNewWithLabelFromWidget rb1 "World" + cb <- checkButtonNewWithLabel "Blacklist" + + boxPackStart box rb1 PackGrow 2 + boxPackStart box rb2 PackGrow 2 + boxPackStart box rb3 PackGrow 2 + boxPackEnd box cb PackNatural 2 + + boxOuter <- vBoxNew False 2 + boxPackStart boxOuter box PackNatural 2 + boxPackStart boxOuter pane' PackGrow 2 + + let modules = IDEModules boxOuter pane' treeView treeStore facetView facetStore + rb1 rb2 rb3 cb + notebookInsertOrdered nb boxOuter (paneName modules) + widgetShowAll boxOuter + cid0 <- treeView `New.onStartInteractiveSearch` + (New.treeViewExpandAll treeView) + cid3 <- treeView `New.onRowActivated` + (\ treePath _ -> do + New.treeViewExpandRow treeView treePath False + return ()) + cid1 <- treeView `afterFocusIn` + (\_ -> do runReaderT (makeActive modules) ideR; return True) + cid2 <- facetView `afterFocusIn` + (\_ -> do runReaderT (makeActive modules) ideR; return True) + treeView `onButtonPress` (treeViewPopup ideR treeStore treeView) + facetView `onButtonPress` (facetViewPopup ideR facetStore facetView) + rb1 `onToggled` (runReaderT scopeSelection ideR) + rb2 `onToggled` (runReaderT scopeSelection ideR) + rb3 `onToggled` (runReaderT scopeSelection ideR) + cb `onToggled` (runReaderT scopeSelection ideR) + sel <- New.treeViewGetSelection treeView + sel `New.onSelectionChanged` (fillFacets treeView treeStore facetStore) + sel2 <- New.treeViewGetSelection facetView + sel2 `New.onSelectionChanged` (fillInfo facetView facetStore ideR) + + return (modules,[cid1,cid2]) + addPaneAdmin buf (BufConnections [] [] []) panePath + lift $widgetGrabFocus (paned buf) + +stockIdFromType :: IdType -> StockId +stockIdFromType Function = "ide_function" +stockIdFromType Newtype = "ide_newtype" +stockIdFromType Type = "ide_type" +stockIdFromType AbstractData = "ide_data" +stockIdFromType OpenData = "ide_data" +stockIdFromType Foreign = "ide_other" +stockIdFromType Data = "ide_data" +stockIdFromType Class = "ide_class" +stockIdFromType Instance = "ide_instance" +stockIdFromType Constructor = "ide_konstructor" +stockIdFromType Field = "ide_slot" +stockIdFromType Method = "ide_method" +stockIdFromType OrphanedInstance = "ide_instance" + +treeViewSearch :: TreeView + -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) + -> Int + -> String + -> TreeIter + -> IO Bool +treeViewSearch treeView treeStore _ string iter = do + path <- New.treeModelGetPath treeStore iter + val <- New.treeStoreGetValue treeStore path + tree <- New.treeStoreGetTree treeStore path + exp <- New.treeViewRowExpanded treeView path + when (not (null (subForest tree)) && not exp) $ + let found = searchInSubnodes tree string + in when found $ do + New.treeViewExpandRow treeView path False + return () + let str2 = case snd val of + [] -> fst val + (m,_):_ -> showPackModule (moduleIdMD m) + return (isInfixOf (map toLower string) (map toLower str2)) + +searchInSubnodes :: ModTree -> String -> Bool +searchInSubnodes tree str = + not $ null + $ filter (\ val -> + let cstr = case snd val of + [] -> fst val + (m,_):_ -> showPackModule (moduleIdMD m) + in isInfixOf (map toLower str) (map toLower cstr)) + $ concatMap flatten (subForest tree) + +fillFacets :: New.TreeView + -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) + -> New.TreeStore FacetWrapper + -> IO () +fillFacets treeView tst treeStore = do + sel <- getSelectionTree treeView tst + case sel of + Just val + -> case snd val of + ((mod,package):_) + -> let forest = buildFacetForrest mod in do + New.treeStoreClear treeStore + mapM_ (\(e,i) -> New.treeStoreInsertTree treeStore [] i e) + $ zip forest [0 .. length forest] + [] -> return () + Nothing + -> New.treeStoreClear treeStore + + +getSelectionTree :: New.TreeView + -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) + -> IO (Maybe (String, [(ModuleDescr,PackageDescr)])) +getSelectionTree treeView treeStore = do + treeSelection <- New.treeViewGetSelection treeView + paths <- New.treeSelectionGetSelectedRows treeSelection + case paths of + [] -> return Nothing + a:r -> do + val <- New.treeStoreGetValue treeStore a + return (Just val) + +getSelectionFacet :: New.TreeView + -> New.TreeStore FacetWrapper + -> IO (Maybe FacetWrapper) +getSelectionFacet treeView treeStore = do + treeSelection <- New.treeViewGetSelection treeView + paths <- New.treeSelectionGetSelectedRows treeSelection + case paths of + a:r -> do + val <- New.treeStoreGetValue treeStore a + return (Just val) + _ -> return Nothing + + +fillInfo :: New.TreeView + -> New.TreeStore FacetWrapper + -> IDERef + -> IO () +fillInfo treeView lst ideR = do + treeSelection <- New.treeViewGetSelection treeView + paths <- New.treeSelectionGetSelectedRows treeSelection + case paths of + [] -> return () + [a] -> do + wrapper <- New.treeStoreGetValue lst a + runReaderT (setInfos [facetIdDescr wrapper]) ideR + return () + _ -> return () + +findDescription :: PackModule -> SymbolTable -> Symbol -> Maybe (Symbol,IdentifierDescr) +findDescription md st s = + case Map.lookup s st of + Nothing -> Nothing + Just l -> case filter (\id -> md == moduleIdID id) l of + [] -> Nothing + l -> Just (s,head l) + +fillModulesList :: (Scope,Bool) -> IDEAction +fillModulesList (scope,useBlacklist) = do + (IDEModules _ _ treeView treeStore _ _ _ _ _ _) <- getModules + prefs <- readIDE prefs + currentInfo' <- readIDE currentInfo + accessibleInfo' <- readIDE accessibleInfo + case currentInfo' of + Nothing -> case (scope,accessibleInfo') of + (World,Just ai@(pm,ps)) -> + let p2 = if useBlacklist + then (Map.filter (filterBlacklist + (packageBlacklist prefs)) pm, ps) + else ai + (Node _ li) = buildModulesTree + ((Map.empty,Map.empty),p2) + in lift $ do + New.treeStoreClear treeStore + mapM_ (\(e,i) -> New.treeStoreInsertTree treeStore [] i e) + $ zip li [0 .. length li] + New.treeViewExpandAll treeView + _ -> lift $ do + New.treeStoreClear treeStore + New.treeStoreInsertTree treeStore [] 0 (Node ("",[]) []) + New.treeViewExpandAll treeView + Just (l,p) -> let (l',p'@(pm,ps)) = case scope of + Local -> (l,(Map.empty,Map.empty)) + Package -> (l,p) + World -> case accessibleInfo' of + Just ai -> (l,ai) + Nothing -> (l,p) + p2 = if useBlacklist + then (Map.filter (filterBlacklist + (packageBlacklist prefs)) pm, ps) + else p' + (Node _ li) = buildModulesTree (l',p2) + in lift $ do + emptyModel <- New.treeStoreNew [] + New.treeViewSetModel treeView emptyModel + New.treeStoreClear treeStore + mapM_ (\(e,i) -> New.treeStoreInsertTree treeStore [] i e) + $ zip li [0 .. length li] + New.treeViewSetModel treeView treeStore + New.treeViewExpandAll treeView + where + filterBlacklist :: [Dependency] -> PackageDescr -> Bool + filterBlacklist dependencies packageDescr = + let packageId = packagePD packageDescr + name = pkgName packageId + version = pkgVersion packageId + in isNothing $ find (\ (Dependency str vr) -> str == name && withinRange version vr) + dependencies + + +type FacetForest = Forest FacetWrapper +type FacetTree = Tree FacetWrapper + + +facetTreeText :: FacetWrapper -> String +facetTreeText (Itself (SimpleDescr id FunctionS _ _ _ _)) = "function " ++ id +facetTreeText (Itself (SimpleDescr id NewtypeS _ _ _ _)) = "newtype " ++ id +facetTreeText (Itself (SimpleDescr id TypeS _ _ _ _)) = "type " ++ id +facetTreeText (Itself (SimpleDescr id _ _ _ _ _)) = id +facetTreeText (Itself (DataDescr id _ _ _ _ _ _)) = "data " ++ id +facetTreeText (Itself (ClassDescr id _ _ _ _ _)) = "class " ++ id +facetTreeText (Itself (InstanceDescr cl _ _ _ _ )) = "instance " ++ cl +facetTreeText (ConstructorW s _) = "constructor " ++ s +facetTreeText (FieldW s _) = "slot " ++ s +facetTreeText (MethodW s _) = "method " ++ s +facetTreeText (OrphanedData (InstanceDescr cl binds _ _ _)) = "instance " ++ cl + ++ " " ++ printBinds binds + where + printBinds [] = "" + printBinds (a:[]) = a + printBinds (a:b) = a ++ " " ++ printBinds b +facetTreeText _ = throwIDE "impossible in facetTreeText" + +facetIdType :: FacetWrapper -> IdType +facetIdType (Itself descr) = idType descr +facetIdType (ConstructorW _ _) = Constructor +facetIdType (FieldW _ _) = Field +facetIdType (MethodW _ _) = Method +facetIdType (OrphanedData _) = OrphanedInstance + +facetIdDescr :: FacetWrapper -> IdentifierDescr +facetIdDescr (Itself descr) = descr +facetIdDescr (ConstructorW _ descr) = descr +facetIdDescr (FieldW _ descr) = descr +facetIdDescr (MethodW _ descr) = descr +facetIdDescr (OrphanedData descr) = descr + +buildFacetForrest :: ModuleDescr -> FacetForest +buildFacetForrest modDescr = + let (instances,other) = partition (\id -> case id of + InstanceDescr _ _ _ _ _ -> True + _ -> False) + $ idDescriptionsMD modDescr + forestWithoutInstances = map buildFacet other + (forest2,orphaned) = foldl addInstances (forestWithoutInstances,[]) + instances + orphanedNodes = map (\ inst -> Node (OrphanedData inst) []) orphaned + in forest2 ++ reverse orphanedNodes + where + buildFacet :: IdentifierDescr -> FacetTree + buildFacet d@(SimpleDescr _ _ _ _ _ _) + = Node (Itself d) [] + buildFacet d@(DataDescr _ _ _ constID fieldsID _ _) + = (Node (Itself d) ((map (\ s -> Node (ConstructorW s d) []) constID) + ++ (map (\ s -> Node (FieldW s d) []) fieldsID))) + buildFacet d@(ClassDescr _ _ _ classOpsID _ _) + = Node (Itself d) (map (\ s -> Node (MethodW s d) []) classOpsID) + buildFacet d@(InstanceDescr _ _ _ _ _) + = throwIDE "Impossible in buildFacet" + + addInstances :: (FacetForest,[IdentifierDescr]) + -> IdentifierDescr + -> (FacetForest,[IdentifierDescr]) + addInstances (forest,orphaned) instDescr = + case foldl (matches instDescr) ([],False) forest of + (f,True) -> (f,orphaned) + (f,False) -> (forest, instDescr:orphaned) + + matches :: IdentifierDescr + -> (FacetForest,Bool) + -> FacetTree + -> (FacetForest,Bool) + matches instDescr (forest,False) (Node (Itself dd@(DataDescr id _ _ _ _ _ _)) sub) + | [id] == binds instDescr + = ((Node (Itself dd) (sub ++ [Node (Itself instDescr) []])):forest,True) + matches instDescr (forest,False) (Node (Itself dd@(SimpleDescr id ty _ _ _ _ )) sub) + | [id] == binds instDescr && ty == NewtypeS + = ((Node (Itself dd) (sub ++ [Node (Itself instDescr) []])):forest,True) + matches _ (forest,b) node = (node:forest,b) + + +type ModTree = Tree (String, [(ModuleDescr,PackageDescr)]) +-- +-- | Make a Tree with a module desription, package description pairs tree to display. +-- Their are nodes with a label but without a module (like e.g. Data). +-- +buildModulesTree :: (PackageScope,PackageScope) -> ModTree +buildModulesTree ((localMap,_),(otherMap,_)) = + let flatPairs = concatMap (\p -> map (\m -> (m,p)) (exposedModulesPD p)) + (Map.elems localMap ++ Map.elems otherMap) + emptyTree = (Node ("",[]) []) + resultTree = foldl insertPairsInTree emptyTree flatPairs + in sortTree resultTree + where + insertPairsInTree :: ModTree -> (ModuleDescr,PackageDescr) -> ModTree + insertPairsInTree tree pair = + let nameArray = breakAtDots [] $ modu $ moduleIdMD $ fst pair + pairedWith = map (\n -> (n,pair)) nameArray + in insertNodesInTree pairedWith tree + + insertNodesInTree :: [(String,(ModuleDescr,PackageDescr))] -> ModTree -> ModTree + insertNodesInTree list@[(str2,pair)] (Node (str1,pairs) forest) = + case partition (\ (Node (s,_) _) -> s == str2) forest of + ([],_) -> (Node (str1,pairs) (makeNodes list : forest)) + ([(Node (_,pairsf) l)],rest) + -> (Node (str1,pairs) ((Node (str2,pair : pairsf) l) : rest)) + (_,_) -> throwIDE "insertNodesInTree: impossible1" + insertNodesInTree list@((str2,pair):tl) (Node (str1,pairs) forest) = + case partition (\ (Node (s,_) _) -> s == str2) forest of + ([],_) -> (Node (str1,pairs) (makeNodes list : forest)) + ([found],rest) -> (Node (str1,pairs) (insertNodesInTree tl found : rest)) + (_,_) -> throwIDE "insertNodesInTree: impossible2" + insertNodesInTree [] t = t + + makeNodes :: [(String,(ModuleDescr,PackageDescr))] -> ModTree + makeNodes [(str,pair)] = Node (str,[pair]) [] + makeNodes ((str,_):tl) = Node (str,[]) [makeNodes tl] + makeNodes _ = throwIDE "Impossible in makeNodes" + +breakAtDots :: [String] -> String -> [String] +breakAtDots res [] = reverse res +breakAtDots res toBreak = let (newRes,newToBreak) = span (\c -> c /= '.') toBreak + in if null newToBreak + then reverse (newRes : res) + else breakAtDots (newRes : res) (tail newToBreak) + + +instance Ord a => Ord (Tree a) where + compare (Node l1 _) (Node l2 _) = compare l1 l2 + +sortTree :: Ord a => Tree a -> Tree a +sortTree (Node l forest) = Node l (sort (map sortTree forest)) + +treeViewPopup :: IDERef + -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) + -> New.TreeView + -> Event + -> IO (Bool) +treeViewPopup ideR store treeView (Button _ click _ _ _ _ button _ _) = do + if button == RightButton + then do + theMenu <- menuNew + item1 <- menuItemNewWithLabel "Edit" + item1 `onActivateLeaf` do + sel <- getSelectionTree treeView store + case sel of + Just (_,[(m,_)]) -> case mbSourcePathMD m of + Nothing -> return () + Just fp -> do + runReaderT (selectSourceBuf fp) ideR + return () + otherwise -> return () + item2 <- menuItemNewWithLabel "ExpandAll" + item2 `onActivateLeaf` (New.treeViewExpandAll treeView) + item3 <- menuItemNewWithLabel "CollapseAll" + item3 `onActivateLeaf` (New.treeViewCollapseAll treeView) + mapM_ (menuShellAppend theMenu) [item1,item2,item3] + menuPopup theMenu Nothing + widgetShowAll theMenu + return True + else if button == LeftButton && click == DoubleClick + then do sel <- getSelectionTree treeView store + case sel of + Just (_,[(m,_)]) -> case mbSourcePathMD m of + Nothing -> return () + Just fp -> do + runReaderT (selectSourceBuf fp) ideR + return () + otherwise -> return () + return True + else return False +treeViewPopup _ _ _ _ = throwIDE "treeViewPopup wrong event type" + +facetViewPopup :: IDERef + -> New.TreeStore FacetWrapper + -> New.TreeView + -> Event + -> IO (Bool) +facetViewPopup ideR store facetView (Button _ click _ _ _ _ button _ _) = do + if button == RightButton + then do + theMenu <- menuNew + item1 <- menuItemNewWithLabel "Go to definition" + item1 `onActivateLeaf` do + sel <- getSelectionFacet facetView store + case sel of + Just wrapper -> runReaderT + (goToDefinition (facetIdDescr wrapper)) ideR + otherwise -> sysMessage Normal "no selection" + menuShellAppend theMenu item1 + menuPopup theMenu Nothing + widgetShowAll theMenu + return True + else if button == LeftButton && click == DoubleClick + then do sel <- getSelectionFacet facetView store + case sel of + Just wrapper -> runReaderT (goToDefinition + (facetIdDescr wrapper)) ideR + otherwise -> sysMessage Normal "no selection" + return True + else do + return False + +facetViewPopup _ _ _ _ = throwIDE "facetViewPopup wrong event type" + +getScope :: IDEM (Scope,Bool) +getScope = do + (IDEModules _ _ treeView treeStore facetView facetStore localScopeB + packageScopeB worldScopeB blacklistB) <- getModules + rb1s <- lift $ toggleButtonGetActive localScopeB + rb2s <- lift $ toggleButtonGetActive packageScopeB + rb3s <- lift $ toggleButtonGetActive worldScopeB + cbs <- lift $ toggleButtonGetActive blacklistB + let scope = if rb1s + then Local + else if rb2s + then Package + else if rb3s + then World + else throwIDE + "ModulesPane.scopeSelection: No check button selected" + return (scope,cbs) + +scopeSelection :: IDEAction +scopeSelection = do + mods@(IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) + <- getModules + mbTreeSelection <- lift $ getSelectionTree treeView treeStore + mbFacetSelection <- lift $ getSelectionFacet facetView facetStore + + sc <- getScope + ts <- lift $ New.treeViewGetSelection treeView + lift $ New.treeSelectionUnselectAll ts + fillModulesList sc + let mbs = (case mbTreeSelection of + Nothing -> Nothing + Just (_,[]) -> Nothing + Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md), + case mbFacetSelection of + Nothing -> Nothing + Just fw -> Just (symbolFromFacetWrapper fw)) + selectNames mbs + lift $ bringPaneToFront mods + +selectNames :: (Maybe String, Maybe Symbol) -> IDEAction +selectNames (mbModuleName, mbIdName) = do + (IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) + <- getModules + case mbModuleName of + Nothing -> return () + Just moduleName -> + let nameArray = breakAtDots [] moduleName + in do + tree <- lift $ New.treeStoreGetTree treeStore [] + case treePathFromNameArray tree nameArray [] of + Nothing -> return () + Just treePath -> lift $ do + New.treeViewExpandToPath treeView treePath + sel <- New.treeViewGetSelection treeView + New.treeSelectionSelectPath sel treePath + col <- New.treeViewGetColumn treeView 0 + New.treeViewScrollToCell treeView treePath (fromJust col) (Just (0.3,0.3)) + case mbIdName of + Nothing -> return () + Just symbol -> do + facetTree <- New.treeStoreGetTree facetStore [] + selF <- New.treeViewGetSelection facetView + case findPathFor symbol facetTree of + Nothing -> sysMessage Normal "no path found" + Just path -> do + New.treeSelectionSelectPath selF path + col <- New.treeViewGetColumn facetView 0 + New.treeViewScrollToCell facetView path (fromJust col) + (Just (0.3,0.3)) + + +symbolFromFacetWrapper :: FacetWrapper -> Symbol +symbolFromFacetWrapper (Itself idDescr) = identifierID idDescr +symbolFromFacetWrapper (ConstructorW _ idDescr) = identifierID idDescr +symbolFromFacetWrapper (FieldW _ idDescr) = identifierID idDescr +symbolFromFacetWrapper (MethodW _ idDescr) = identifierID idDescr +symbolFromFacetWrapper (OrphanedData idDescr) = identifierID idDescr + +reloadKeepSelection :: IDEAction +reloadKeepSelection = do + mbMod <- getPane ModulesCasting + case mbMod of + Nothing -> return () + Just mods@(IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) + -> do + mbTreeSelection <- lift $ getSelectionTree treeView treeStore + mbFacetSelection <- lift $ getSelectionFacet facetView facetStore + sc <- getScope + fillModulesList sc + lift $ New.treeStoreClear facetStore + let mbs = (case mbTreeSelection of + Nothing -> Nothing + Just (_,[]) -> Nothing + Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md), + case mbFacetSelection of + Nothing -> Nothing + Just fw -> Just (symbolFromFacetWrapper fw)) + selectNames mbs + + + + + + + diff --git a/src/IDE/Package.hs b/src/IDE/Package.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Package.hs @@ -0,0 +1,558 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Package +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- +-- | The packages methods of ide. +-- +--------------------------------------------------------------------------------- + + +module IDE.Package ( + packageOpen +, packageConfig +, packageBuild +, packageDoc +, packageClean +, packageCopy +, packageRun +, nextError +, previousError +, activatePackage +, deactivatePackage +, packageFlags + +, packageInstall +, packageRegister +, packageUnregister +, packageTest +, packageSdist +, packageOpenDoc +) where + +import Graphics.UI.Gtk +import Control.Monad.Reader +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Verbosity +import System.FilePath +import Control.Concurrent +import System.Directory +import System.IO +--import System.Process +import Prelude hiding (catch) +import Text.ParserCombinators.Parsec.Language +import qualified Text.ParserCombinators.Parsec.Token as P +import Text.ParserCombinators.Parsec hiding(Parser) +import Data.Maybe(isJust,fromJust) +import Control.Exception hiding (try) +import System.Process + +import IDE.Log +import IDE.Core.State +import IDE.PackageEditor +import IDE.SourceEditor +import IDE.PackageFlags +import IDE.Framework.ViewFrame +import IDE.Metainfo.Info + +packageOpen :: IDEAction +packageOpen = do + active <- readIDE activePack + case active of + Just p -> deactivatePackage + Nothing -> return () + selectActivePackage + return () + +getActivePackage :: IDEM (Maybe IDEPackage) +getActivePackage = do + active <- readIDE activePack + case active of + Just p -> return (Just p) + Nothing -> selectActivePackage + +activatePackage :: FilePath -> IDEM (Maybe IDEPackage) +activatePackage filePath = do + session <- readIDE session + let ppath = dropFileName filePath + lift $setCurrentDirectory ppath + ideR <- ask + mbPackageD <- lift $ catch (do + pd <- readPackageDescription normal filePath + return (Just (flattenPackageDescription pd))) + (\e -> do + runReaderT (ideMessage Normal ("Can't activate package " ++(show e))) ideR + return Nothing) + case mbPackageD of + Nothing -> return (Nothing) + Just packageD -> do + let packp = IDEPackage (package packageD) filePath (buildDepends packageD) [] [] [] [] [] [] [] [] + pack <- (do + flagFileExists <- lift $doesFileExist (ppath "IDE.flags") + if flagFileExists + then lift $readFlags (ppath "IDE.flags") packp + else return packp) + modifyIDE_ (\ide -> return (ide{activePack = (Just pack)})) + ide <- getIDE + triggerEvent ideR ActivePack + sb <- getSBActivePackage + lift $statusbarPop sb 1 + lift $statusbarPush sb 1 (showPackageId $packageId pack) + return (Just pack) + +deactivatePackage :: IDEAction +deactivatePackage = do + modifyIDE_ (\ide -> return (ide{activePack = Nothing})) + ideR <- ask + triggerEvent ideR ActivePack + sb <- getSBActivePackage + lift $statusbarPop sb 1 + lift $statusbarPush sb 1 "" + return () + +packageFlags :: IDEAction +packageFlags = do + active <- getActivePackage + case active of + Nothing -> return () + Just p -> do + editFlags + active2 <- getActivePackage + case active2 of + Nothing -> do + ideMessage Normal "no more active package" + return () + Just p -> + lift $writeFlags ((dropFileName (cabalFile p)) "IDE.flags") p + +selectActivePackage :: IDEM (Maybe IDEPackage) +selectActivePackage = do + window <- readIDE window + mbFilePath <- lift $choosePackageFile window + case mbFilePath of + Nothing -> return Nothing + Just filePath -> activatePackage filePath + + +packageConfig :: IDEAction +packageConfig = do + mbPackage <- getActivePackage + log <- getLog + ideR <- ask + case mbPackage of + Nothing -> return () + Just package -> do + mbPackageD <- lift $ catch (do + (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","configure"] + ++ (configFlags package)) + oid <- forkIO(readOut log out) + eid <- forkIO (readErr log err) + pd <- readPackageDescription normal (cabalFile package) + return (Just (flattenPackageDescription pd))) + (\e -> do + runReaderT (ideMessage Normal (show e)) ideR + return Nothing) + case mbPackageD of + Just packageD -> do + modifyIDE_ (\ide -> return (ide{activePack = + Just package{depends=buildDepends packageD}})) + triggerEvent ideR ActivePack + return () + Nothing -> return () + +packageBuild :: IDEAction +packageBuild = do + mbPackage <- getActivePackage + log <- getLog + ideR <- ask + case mbPackage of + Nothing -> return () + Just package -> do + sb <- getSBErrors + lift $statusbarPop sb 1 + lift $statusbarPush sb 1 "Building" + unmarkCurrentError + pid' <- lift $do + (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","build"] + ++ buildFlags package) + oid <- forkIO (readOut log out) + eid <- forkIO (runReaderT (readErrForBuild log err) ideR) + return pid + mayRebuildInBackground (Just pid') + +packageDoc :: IDEAction +packageDoc = do + mbPackage <- getActivePackage + log <- getLog + case mbPackage of + Nothing -> return () + Just package -> lift $do + (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","haddock"] + ++ (haddockFlags package)) + oid <- forkIO (readOut log out) + eid <- forkIO (readErr log err) + return () + +packageClean :: IDEAction +packageClean = do + mbPackage <- getActivePackage + log <- getLog + case mbPackage of + Nothing -> return () + Just package -> lift $do + (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","clean"] + ++ (haddockFlags package)) + oid <- forkIO (readOut log out) + eid <- forkIO (readErr log err) + return () + +packageCopy :: IDEAction +packageCopy = do + mbPackage <- getActivePackage + log <- getLog + mbDir <- chooseDir "Select the target directory" + case mbDir of + Nothing -> return () + Just fp -> + case mbPackage of + Nothing -> return () + Just package -> lift $do + (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","copy"] + ++ ["--destdir=" ++ fp]) + oid <- forkIO (readOut log out) + eid <- forkIO (readErr log err) + return () + +packageRun :: IDEAction +packageRun = do + mbPackage <- getActivePackage + log <- getLog + case mbPackage of + Nothing -> return () + Just package -> lift $do + pd <- readPackageDescription normal (cabalFile package) >>= return . flattenPackageDescription + case executables pd of + [(Executable name _ _)] -> do + let path = "dist/build" pkgName (packageId package) name + (inp,out,err,pid) <- runExternal path (exeFlags package) + oid <- forkIO (readOut log out) + eid <- forkIO (readErr log err) + return () + otherwise -> do + sysMessage Normal "no single executable in selected package" + return () + +packageInstall :: IDEAction +packageInstall = do + mbPackage <- getActivePackage + log <- getLog + case mbPackage of + Nothing -> return () + Just package -> lift $do + (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","install"] + ++ (installFlags package)) + oid <- forkIO (readOut log out) + eid <- forkIO (readErr log err) + return () + +packageRegister :: IDEAction +packageRegister = do + mbPackage <- getActivePackage + log <- getLog + case mbPackage of + Nothing -> return () + Just package -> lift $do + (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","register"] + ++ (registerFlags package)) + oid <- forkIO (readOut log out) + eid <- forkIO (readErr log err) + return () + +packageUnregister :: IDEAction +packageUnregister = do + mbPackage <- getActivePackage + log <- getLog + case mbPackage of + Nothing -> return () + Just package -> lift $do + (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","unregister"] + ++ (unregisterFlags package)) + oid <- forkIO (readOut log out) + eid <- forkIO (readErr log err) + return () + +packageTest :: IDEAction +packageTest = do + mbPackage <- getActivePackage + log <- getLog + case mbPackage of + Nothing -> return () + Just package -> lift $do + (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","test"]) + oid <- forkIO (readOut log out) + eid <- forkIO (readErr log err) + return () + +packageSdist :: IDEAction +packageSdist = do + mbPackage <- getActivePackage + log <- getLog + case mbPackage of + Nothing -> return () + Just package -> lift $do + (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","sdist"] + ++ (sdistFlags package)) + oid <- forkIO (readOut log out) + eid <- forkIO (readErr log err) + return () + +packageOpenDoc :: IDEAction +packageOpenDoc = do + mbPackage <- getActivePackage + prefs <- readIDE prefs + log <- getLog + case mbPackage of + Nothing -> return () + Just package -> lift $do + let path = "dist/doc/html" pkgName (packageId package) "index.html" + (inp,out,err,pid) <- runExternal (browser prefs) [path] + oid <- forkIO (readOut log out) + eid <- forkIO (readErr log err) + return () + +chooseDir :: String -> IDEM (Maybe FilePath) +chooseDir str = do + win <- readIDE window + lift $do + dialog <- fileChooserDialogNew + (Just $ str) + (Just win) + FileChooserActionSelectFolder + [("gtk-cancel" + ,ResponseCancel) + ,("gtk-open" + ,ResponseAccept)] + widgetShow dialog + response <- dialogRun dialog + case response of + ResponseAccept -> do + fn <- fileChooserGetFilename dialog + widgetDestroy dialog + return fn + ResponseCancel -> do + widgetDestroy dialog + return Nothing + ResponseDeleteEvent -> do + widgetDestroy dialog + return Nothing + _ -> return Nothing + +-- --------------------------------------------------------------------- +-- | Handling of Compiler errors +-- + +readErrForBuild :: IDELog -> Handle -> IDEAction +readErrForBuild log hndl = do + errs <- lift $readAndShow False [] + modifyIDE_ (\ide -> return (ide{errors = reverse errs, currentErr = Nothing})) + sb <- getSBErrors + let errorNum = length (filter isError errs) + let warnNum = length errs - errorNum + lift $statusbarPop sb 1 + lift $statusbarPush sb 1 $show errorNum ++ " Errors, " ++ show warnNum ++ " Warnings" + when (not (null errs)) nextError + where + readAndShow inError errs = do + isEnd <- hIsEOF hndl + if isEnd + then return errs + else do + line <- hGetLine hndl + let parsed = parse buildLineParser "" line + lineNr <- appendLog log (line ++ "\n") ErrorTag + case (parsed, errs) of + (Left e,_) -> do + sysMessage Normal (show e) + readAndShow False errs + (Right ne@(ErrorLine fp l c str),_) -> + readAndShow True ((ErrorSpec fp l c str (lineNr,lineNr) True):errs) + (Right (OtherLine str1),(ErrorSpec fp i1 i2 str (l1,l2) isError):tl) -> + if inError + then readAndShow True ((ErrorSpec fp i1 i2 + (if null str + then line + else str ++ "\n" ++ line) + (l1,lineNr) isError) : tl) + else readAndShow False errs + (Right (WarningLine str1),(ErrorSpec fp i1 i2 str (l1,l2) isError):tl) -> + if inError + then readAndShow True ((ErrorSpec fp i1 i2 + (if null str + then line + else str ++ "\n" ++ line) + (l1,lineNr) False) : tl) + else readAndShow False errs + otherwise -> readAndShow False errs + +selectErr :: Int -> IDEAction +selectErr index = do + errors <- readIDE errors + if length errors < index + 1 + then return () + else do + let thisErr = errors !! index + succ <- selectSourceBuf (filePath thisErr) + if succ + then markErrorInSourceBuf (line thisErr) (column thisErr) + (errDescription thisErr) + else return () + log :: IDELog <- getLog + lift $ markErrorInLog log (logLines thisErr) + +unmarkCurrentError :: IDEAction +unmarkCurrentError = do + currentErr' <- readIDE currentErr + errors' <- readIDE errors + when (isJust currentErr') $ do + let theError = errors' !! fromJust currentErr' + allBufs <- allBuffers + fpc <- lift $ canonicalizePath $ filePath theError + let theBufs = filter (\ buf -> isJust (fileName buf) && + equalFilePath fpc (fromJust (fileName buf))) + allBufs + mapM_ removeMark theBufs + where + removeMark buf = lift $ do + gtkbuf <- textViewGetBuffer (sourceView buf) + i1 <- textBufferGetStartIter gtkbuf + i2 <- textBufferGetEndIter gtkbuf + textBufferRemoveTagByName gtkbuf "activeErr" i1 i2 + +nextError :: IDEAction +nextError = do + errs <- readIDE errors + currentErr <- readIDE currentErr + if null errs + then return () + else do + case currentErr of + Nothing -> do + modifyIDE_ (\ide -> return (ide{currentErr = Just 0})) + selectErr 0 + Just n | (n + 1) < length errs -> do + modifyIDE_ (\ide -> return (ide{currentErr = Just (n + 1)})) + selectErr (n + 1) + Just n -> selectErr n + +previousError :: IDEAction +previousError = do + errs <- readIDE errors + currentErr <- readIDE currentErr + if null errs + then return () + else do + case currentErr of + Nothing -> do + modifyIDE_ (\ide -> return (ide{currentErr = Just (length errs - 1)})) + selectErr (length errs - 1) + Just n | n > 0 -> do + modifyIDE_ (\ide -> return (ide{currentErr = Just (n - 1)})) + selectErr (n - 1) + otherwise -> selectErr 0 + +data BuildError = BuildLine + | EmptyLine + | ErrorLine FilePath Int Int String + | WarningLine String + | OtherLine String + +buildLineParser :: CharParser () BuildError +buildLineParser = try (do + char '[' + integer + symbol "of" + integer + char '[' + many (anyChar) + return BuildLine) + <|> try (do + filePath <- many (noneOf ":") + char ':' + line <- integer + char ':' + column <- integer + char ':' + whiteSpace + text <- many anyChar + return (ErrorLine filePath (fromIntegral line) (fromIntegral column) text)) + <|> try (do + whiteSpace + eof + return EmptyLine) + <|> try (do + whiteSpace + symbol "Warning:" + text <- many anyChar + return (WarningLine ("Warning:" ++ text))) + <|> try (do + text <- many anyChar + eof + return (OtherLine text)) + "buildLineParser" + + +lexer = P.makeTokenParser emptyDef +lexeme = P.lexeme lexer +whiteSpace = P.whiteSpace lexer +hexadecimal = P.hexadecimal lexer +symbol = P.symbol lexer +identifier = P.identifier lexer +colon = P.colon lexer +integer = P.integer lexer + +-- Spawning external processes + +readOut :: IDELog -> Handle -> IO () +readOut log hndl = + catch (readAndShow) + (\e -> do + --appendLog log ("----------------------------------------\n") FrameTag + hClose hndl + return ()) + where + readAndShow = do + line <- hGetLine hndl + appendLog log (line ++ "\n") LogTag + readAndShow + +readErr :: IDELog -> Handle -> IO () +readErr log hndl = + catch (readAndShow) + (\e -> do + hClose hndl + return ()) + where + readAndShow = do + line <- hGetLine hndl + appendLog log (line ++ "\n") ErrorTag + readAndShow + +runExternal :: FilePath -> [String] -> IO (Handle, Handle, Handle, ProcessHandle) +runExternal path args = do + putStrLn $ "Run external called with args " ++ show args + hndls@(inp, out, err, _) <- runInteractiveProcess path args Nothing Nothing + sysMessage Normal $ "Starting external tool: " ++ path ++ " with args " ++ (show args) + hSetBuffering out NoBuffering + hSetBuffering err NoBuffering + hSetBuffering inp NoBuffering + hSetBinaryMode out True + hSetBinaryMode err True + return hndls diff --git a/src/IDE/PackageEditor.hs b/src/IDE/PackageEditor.hs new file mode 100644 --- /dev/null +++ b/src/IDE/PackageEditor.hs @@ -0,0 +1,368 @@ +----------------------------------------------------------------------------- +-- +-- Module : IDE.PackageEditor +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | Module for editing of cabal packages +-- +----------------------------------------------------------------------------------- + + +module IDE.PackageEditor ( + packageNew +, packageEdit +, choosePackageDir +, choosePackageFile +) where + +import Graphics.UI.Gtk +import Control.Monad.Reader +import Distribution.Compiler +import Distribution.License +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Version +import Distribution.Verbosity +import System.FilePath +import Data.IORef +import Data.List +import Data.Maybe +import System.Directory + +import IDE.Core.State +import IDE.Utils.File +import IDE.SpecialEditors +import IDE.Framework.ViewFrame +import IDE.BuildInfoEditor +import IDE.Framework.MakeEditor +import IDE.Framework.SimpleEditors +import IDE.Framework.CompositeEditors +import IDE.Framework.Parameters + +standardSetup = "#!/usr/bin/runhaskell \n" + ++ "> module Main where\n" + ++ "> import Distribution.Simple\n" + ++ "> main :: IO ()\n" + ++ "> main = defaultMain\n\n" + +choosePackageDir :: Window -> IO (Maybe FilePath) +choosePackageDir window = do + dialog <- fileChooserDialogNew + (Just $ "Select root folder for project") + (Just window) + FileChooserActionSelectFolder + [("gtk-cancel" + ,ResponseCancel) + ,("gtk-open" + ,ResponseAccept)] + widgetShow dialog + response <- dialogRun dialog + case response of + ResponseAccept -> do + fn <- fileChooserGetFilename dialog + widgetDestroy dialog + return fn + ResponseCancel -> do + widgetDestroy dialog + return Nothing + ResponseDeleteEvent -> do + widgetDestroy dialog + return Nothing + _ -> return Nothing + +choosePackageFile :: Window -> IO (Maybe FilePath) +choosePackageFile window = do + dialog <- fileChooserDialogNew + (Just $ "Select file of project") + (Just window) + FileChooserActionOpen + [("gtk-cancel" + ,ResponseCancel) + ,("gtk-open" + ,ResponseAccept)] + widgetShow dialog + response <- dialogRun dialog + case response of + ResponseAccept -> do + fn <- fileChooserGetFilename dialog + widgetDestroy dialog + return fn + ResponseCancel -> do + widgetDestroy dialog + return Nothing + ResponseDeleteEvent -> do + widgetDestroy dialog + return Nothing + _ -> return Nothing + +packageEdit :: IDEAction +packageEdit = do + window <- readIDE window + mbFileName <- lift $choosePackageFile window + case mbFileName of + Nothing -> return () + Just fileName -> do + let dirName = dropFileName fileName + modules <- lift $allModules dirName + package <- lift $readPackageDescription normal fileName + editPackage (flattenPackageDescription package) dirName modules + return () + +packageNew :: IDEAction +packageNew = do + window <- readIDE window + mbDirName <- lift $choosePackageDir window + case mbDirName of + Nothing -> return () + Just dirName -> do + cfn <- lift $cabalFileName dirName + continue <- do + if isJust cfn + then lift $do + md <- messageDialogNew Nothing [] MessageQuestion ButtonsYesNo + $ "There is already a .cabal file in this directory." + ++ " Continue anyway?" + rid <- dialogRun md + widgetDestroy md + case rid of + ResponseYes -> return True + otherwise -> return False + else return True + when continue $do + modules <- lift $do + b1 <- doesFileExist (dirName "Setup.hs") + b2 <- doesFileExist (dirName "Setup.lhs") + if not (b1 || b2) + then do + sysMessage Normal "Setup.(l)hs does not exist. Writing Standard" + writeFile (dirName "Setup.lhs") standardSetup + else sysMessage Normal "Setup.(l)hs already exist" + allModules dirName + editPackage emptyPackageDescription dirName modules + return () + +type PDescr = [(String,[FieldDescription PackageDescription])] + +packageDD :: FilePath -> [String] -> PDescr +packageDD fp modules = [ + ("Description -1-", [ + mkField + (paraName <<<- ParaName "Package Identifier" $ emptyParams) + package + (\ a b -> b{package = a}) + packageEditor + , mkField + (paraName <<<- ParaName "Cabal version" + $ paraSynopsis <<<- ParaSynopsis + "Does this package depends on a specific version of Cabal?" + $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams) + descCabalVersion + (\ a b -> b{descCabalVersion = a}) + versionRangeEditor + , mkField + (paraName <<<- ParaName "License" $ emptyParams) + license + (\ a b -> b{license = a}) + (staticSelectionEditor [GPL, LGPL, BSD3, BSD4, PublicDomain, AllRightsReserved, OtherLicense]) + , mkField + (paraName <<<- ParaName "License File" $ emptyParams) + licenseFile + (\ a b -> b{licenseFile = a}) + (fileEditor (Just fp) FileChooserActionOpen "Select file") + , mkField + (paraName <<<- ParaName "Copyright" $ emptyParams) + copyright + (\ a b -> b{copyright = a}) + stringEditor + , mkField + (paraName <<<- ParaName "Author" $ emptyParams) + author + (\ a b -> b{author = a}) + stringEditor + , mkField + (paraName <<<- ParaName "Maintainer" $ emptyParams) + maintainer + (\ a b -> b{maintainer = a}) + stringEditor + ]), + ("Description -2-",[ + mkField + (paraName <<<- ParaName "Stability" $ emptyParams) + stability + (\ a b -> b{stability = a}) + stringEditor + , mkField + (paraName <<<- ParaName "Homepage" $ emptyParams) + homepage + (\ a b -> b{homepage = a}) + stringEditor + , mkField + (paraName <<<- ParaName "Package URL" $ emptyParams) + pkgUrl + (\ a b -> b{pkgUrl = a}) + stringEditor + , mkField + (paraName <<<- ParaName "Synopsis" + $ paraSynopsis <<<- ParaSynopsis "A one-line summary of this package" + $ emptyParams) + synopsis + (\ a b -> b{synopsis = a}) + stringEditor + , mkField + (paraName <<<- ParaName "Description" + $ paraSynopsis <<<- ParaSynopsis "A more verbose description of this package" + $ paraShadow <<<- ParaShadow ShadowOut + $ paraMinSize <<<- ParaMinSize (-1,250) + $ emptyParams) + description + (\ a b -> if null a then b{description = " \n\n\n\n\n"} else b{description = a}) + multilineStringEditor + , mkField + (paraName <<<- ParaName "Category" $ emptyParams) + category + (\ a b -> b{category = a}) + stringEditor + ]), + ("Tested With",[ + mkField + (paraName <<<- ParaName "Tested with compiler" + $ paraShadow <<<- ParaShadow ShadowIn + $ paraDirection <<<- ParaDirection Vertical + $ emptyParams) + (\a -> case testedWith a of + [] -> [(GHC,AnyVersion)] + l -> l) + (\ a b -> b{testedWith = a}) + testedWidthEditor + ]), + ("Dependencies",[ + mkField + (paraName <<<- ParaName "Build Dependencies" + $ paraSynopsis <<<- ParaSynopsis "Does this package depends on other packages?" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + buildDepends + (\ a b -> b{buildDepends = a}) + dependenciesEditor + ]), + ("Other Files",[ + mkField + (paraName <<<- ParaName "Data Files" + $ paraSynopsis <<<- ParaSynopsis + "A list of files to be installed for run-time use by the package." + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + dataFiles + (\ a b -> b{dataFiles = a}) + (filesEditor (Just fp) FileChooserActionOpen "Select File") + , mkField + (paraName <<<- ParaName "Extra Source Files" + $ paraSynopsis <<<- ParaSynopsis + "A list of additional files to be included in source distributions." + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + extraSrcFiles + (\ a b -> b{extraSrcFiles = a}) + (filesEditor (Just fp) FileChooserActionOpen "Select File") + , mkField + (paraName <<<- ParaName "Extra Tmp Files" + $ paraSynopsis <<<- ParaSynopsis + "A list of additional files or directories to be removed by setup clean." + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + extraTmpFiles + (\ a b -> b{extraTmpFiles = a}) + (filesEditor (Just fp) FileChooserActionOpen "Select File") + ]), + ("Library",[ + mkField + (paraName <<<- ParaName "Library" + $ paraSynopsis <<<- ParaSynopsis + "If the package contains a library, specify the exported modules here" + $ paraDirection <<<- ParaDirection Vertical + $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams) + library + (\ a b -> b{library = a}) + (maybeEditor (libraryEditor BuildEditorFactoryI (Just fp) modules, + paraName <<<- ParaName "Specify exported modules" $ emptyParams) True + "Does this package contain a library?") + ]), + ("Executables",[ + mkField + (paraName <<<- ParaName "Executables" + $ paraSynopsis <<<- ParaSynopsis + "Describe executable programs contained in the package" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + executables + (\ a b -> b{executables = a}) + (executablesEditor BuildEditorFactoryI (Just fp) modules) + ])] + + +editPackage :: PackageDescription -> FilePath -> [String] -> IDEAction +editPackage packageD packageDir modules = do + ideR <- ask + lift $editPackage' packageDir packageD (packageDD packageDir modules) ideR +-- ideMessage Normal $show res + +editPackage' :: String -> PackageDescription -> PDescr -> IDERef -> IO () +editPackage' packageDir packageD packageDD ideR = + let flatPackageDesc = concatMap snd packageDD + in do + lastAppliedPackageRef <- newIORef packageD + dialog <- windowNew + vb <- vBoxNew False 7 + bb <- hButtonBoxNew + restore <- buttonNewFromStock "Restore" + ok <- buttonNewFromStock "gtk-ok" + cancel <- buttonNewFromStock "gtk-cancel" + boxPackStart bb restore PackNatural 0 + boxPackStart bb ok PackNatural 0 + boxPackStart bb cancel PackNatural 0 + nb <- newNotebook + notebookSetTabPos nb PosTop + res <- mapM + (\ (tabLabel, partPackageDesc) -> do + resList <- mapM (\ (FD _ editorF) -> editorF packageD) partPackageDesc + let (widgetsP, setInjsP, getExtsP, notifiersP) = unzip4 resList + nbbox <- vBoxNew False 0 + mapM_ (\ w -> boxPackStart nbbox w PackNatural 0) widgetsP + sw <- scrolledWindowNew Nothing Nothing + scrolledWindowAddWithViewport sw nbbox + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + notebookAppendPage nb sw tabLabel + return (widgetsP, setInjsP, getExtsP, notifiersP)) + packageDD + let (widgets, setInjs, getExts, notifiers) = + foldl (\ (w,i,e,n) (w2,i2,e2,n2) -> (w ++ w2, i ++ i2, e ++ e2, n ++ n2)) ([],[],[],[]) res + let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of + Just s -> s + Nothing -> "Unnamed") + $concat + $map snd packageDD + ok `onClicked` (do + mbNewPackage <- extractAndValidate packageD getExts fieldNames + case mbNewPackage of + Nothing -> return () + Just newPackage -> do + lastAppliedPackage <- readIORef lastAppliedPackageRef + let PackageIdentifier n v = package newPackage + writePackageDescription (packageDir ++ "/" ++ n ++ ".cabal") newPackage + widgetDestroy dialog + mainQuit) + cancel `onClicked` (do + widgetDestroy dialog + mainQuit) + dialog `onDelete` (\e -> do + widgetDestroy dialog + mainQuit + return True) + boxPackStart vb nb PackGrow 7 + boxPackEnd vb bb PackNatural 7 + containerAdd dialog vb + widgetSetSizeRequest dialog 500 700 + widgetShowAll dialog + mainGUI + return () + diff --git a/src/IDE/PackageFlags.hs b/src/IDE/PackageFlags.hs new file mode 100644 --- /dev/null +++ b/src/IDE/PackageFlags.hs @@ -0,0 +1,209 @@ +----------------------------------------------------------------------------- +-- +-- Module : IDE.PackageFlags +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- +-- | Module for saving, restoring and editing projectFlags +-- +--------------------------------------------------------------------------------- + + +module IDE.PackageFlags ( + readFlags +, writeFlags +, editFlags +) where + +import Graphics.UI.Gtk +import Control.Monad.Reader +import qualified Text.ParserCombinators.Parsec as P +import Data.List +import System.IO +import qualified Text.PrettyPrint.HughesPJ as PP + +import IDE.Core.State +import IDE.Framework.MakeEditor hiding (fieldEditor, parameters) +import IDE.Framework.SimpleEditors +import IDE.Framework.Parameters + +import IDE.PrinterParser hiding (fieldParser, parameters) +import IDE.Framework.ViewFrame +import IDE.DescriptionPP + +concatString :: [String] -> String +concatString l = foldl (\r s -> if null r then s else r ++ " " ++ s) "" l + +flagsDescription :: [(String,[FieldDescriptionPP IDEPackage])] +flagsDescription = [ + ("Flags", [ + mkFieldPP + (paraName <<<- ParaName "Config flags" $ emptyParams) + (PP.text . show) + stringParser + (\p -> concatString (configFlags p)) + (\ b a -> a{configFlags = if null b then [] else [b]}) + stringEditor + (\ _ -> return ()) + , mkFieldPP + (paraName <<<- ParaName "Build flags" $ emptyParams) + (PP.text . show) + stringParser + (\p -> concatString (buildFlags p)) + (\ b a -> a{buildFlags = if null b then [] else [b]}) + stringEditor + (\ _ -> return ()) + , mkFieldPP + (paraName <<<- ParaName "Haddock flags" $ emptyParams) + (PP.text . show) + stringParser + (\p -> concatString (haddockFlags p)) + (\ b a -> a{haddockFlags = if null b then [] else [b]}) + stringEditor + (\ _ -> return ()) + , mkFieldPP + (paraName <<<- ParaName "Executable flags" $ emptyParams) + (PP.text . show) + stringParser + (\p -> concatString (exeFlags p)) + (\ b a -> a{exeFlags = if null b then [] else [b]}) + stringEditor + (\ _ -> return ()) + , mkFieldPP + (paraName <<<- ParaName "Install flags" $ emptyParams) + (PP.text . show) + stringParser + (\p -> concatString (installFlags p)) + (\ b a -> a{installFlags = if null b then [] else [b]}) + stringEditor + (\ _ -> return ()) + , mkFieldPP + (paraName <<<- ParaName "Register flags" $ emptyParams) + (PP.text . show) + stringParser + (\p -> concatString (registerFlags p)) + (\ b a -> a{registerFlags = if null b then [] else [b]}) + stringEditor + (\ _ -> return ()) + , mkFieldPP + (paraName <<<- ParaName "Unregister flags" $ emptyParams) + (PP.text . show) + stringParser + (\p -> concatString (unregisterFlags p)) + (\ b a -> a{unregisterFlags = if null b then [] else [b]}) + stringEditor + (\ _ -> return ()) + , mkFieldPP + (paraName <<<- ParaName "Source Distribution flags" $ emptyParams) + (PP.text . show) + stringParser + (\p -> concatString (sdistFlags p)) + (\ b a -> a{sdistFlags = if null b then [] else [b]}) + stringEditor + (\ _ -> return ()) + ])] + +-- ------------------------------------------------------------ +-- * Parsing +-- ------------------------------------------------------------ + +readFlags :: FilePath -> IDEPackage -> IO IDEPackage +readFlags fn pack = do + res <- P.parseFromFile (flagsParser pack (concatMap snd flagsDescription)) fn + case res of + Left pe -> throwIDE $"Error reading flags file " ++ show fn ++ " " ++ show pe + Right r -> return r + +flagsParser :: a -> [FieldDescriptionPP a] -> P.CharParser () a +flagsParser def descriptions = + let parsersF = map fieldParser descriptions in do + whiteSpace + res <- applyFieldParsers def parsersF + return res + P. "flags parser" + +-- ------------------------------------------------------------ +-- * Printing +-- ------------------------------------------------------------ + +writeFlags :: FilePath -> IDEPackage -> IO () +writeFlags fpath flags = + writeFile fpath (showFlags flags (concatMap snd flagsDescription)) + +showFlags :: a -> [FieldDescriptionPP a] -> String +showFlags flags flagsDesc = PP.render $ + foldl (\ doc (FDPP _ printer _ _ _ ) -> doc PP.$+$ printer flags) PP.empty flagsDesc + +-- ------------------------------------------------------------ +-- * Editing +-- ------------------------------------------------------------ + +editFlags :: IDEAction +editFlags = do + ideR <- ask + mbP <- readIDE activePack + case mbP of + Nothing -> return () + Just p -> lift $editFlags' p flagsDescription ideR + + +editFlags' :: IDEPackage -> [(String,[FieldDescriptionPP IDEPackage])] -> IDERef -> IO () +editFlags' flags flagsDesc ideR = do + let flatflagsDesc = concatMap snd flagsDesc + dialog <- windowNew + vb <- vBoxNew False 0 + bb <- hButtonBoxNew + ok <- buttonNewFromStock "gtk-ok" + cancel <- buttonNewFromStock "gtk-cancel" + boxPackStart bb ok PackNatural 0 + boxPackStart bb cancel PackNatural 0 + nb <- newNotebook + notebookSetTabPos nb PosTop + res <- mapM + (\ (tabLabel, partflagsDesc) -> do + resList <- mapM (\ fd -> (fieldEditor fd) flags) partflagsDesc + let (widgetsP, setInjsP, getExtsP,notifiersP) = unzip4 resList + nbbox <- vBoxNew False 0 + mapM_ (\ w -> boxPackStart nbbox w PackNatural 0) widgetsP + sw <- scrolledWindowNew Nothing Nothing + scrolledWindowAddWithViewport sw nbbox + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + notebookAppendPage nb sw tabLabel + return (widgetsP, setInjsP, getExtsP, notifiersP)) + flagsDesc + let (widgets, setInjs, getExts, notifiers) = + foldl (\ (w,i,e,n) (w2,i2,e2,n2) -> (w ++ w2, i ++ i2, e ++ e2, n ++ n2)) ([],[],[],[]) res + let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of + Just s -> s + Nothing -> "Unnamed") flatflagsDesc + ok `onClicked` (do + mbPackWithNewFlags <- extractAndValidate flags getExts fieldNames + case mbPackWithNewFlags of + Nothing -> return () + Just packWithNewFlags -> do + runReaderT (modifyIDE_ (\ide -> return (ide{activePack = Just packWithNewFlags}))) + ideR -- we don't trigger the activePack event here + widgetDestroy dialog + mainQuit) + cancel `onClicked` (do + widgetDestroy dialog + mainQuit) + boxPackStart vb nb PackGrow 7 + boxPackEnd vb bb PackNatural 7 + containerAdd dialog vb + widgetSetSizeRequest dialog 500 700 + widgetShowAll dialog + mainGUI + return () + + + + + + + diff --git a/src/IDE/Preferences.hs b/src/IDE/Preferences.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Preferences.hs @@ -0,0 +1,350 @@ +----------------------------------------------------------------------------- +-- +-- Module : IDE.Preferences +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- +-- | Module for saving, restoring and editing preferences +-- +--------------------------------------------------------------------------------- + + +module IDE.Preferences ( + readPrefs +, writePrefs +, defaultPrefs +, prefsDescription +, editPrefs +) where + +import Graphics.UI.Gtk.SourceView +import Graphics.UI.Gtk +import Control.Monad.Reader +import qualified Text.ParserCombinators.Parsec as P +import Data.List +import qualified Text.PrettyPrint.HughesPJ as PP +import Distribution.Package +import Data.IORef + +import IDE.Core.State +import IDE.Framework.ViewFrame +import IDE.Framework.SimpleEditors +import IDE.Framework.CompositeEditors +import IDE.Framework.Parameters +import IDE.Framework.MakeEditor hiding (fieldEditor,parameters) +import IDE.DescriptionPP +import IDE.PrinterParser hiding (fieldParser,parameters) +import IDE.SourceEditor +import IDE.Log +import IDE.SpecialEditors +import IDE.Utils.Default +import IDE.Utils.File + + +prefsDescription :: [(String,[FieldDescriptionPP Prefs])] +prefsDescription = [ + ("Editor", [ + mkFieldPP + (paraName <<<- ParaName "Show line numbers" + $ paraSynopsis <<<- ParaSynopsis "(True/False)" $ emptyParams) + (PP.text . show) + boolParser + showLineNumbers + (\ b a -> a{showLineNumbers = b}) + boolEditor + (\b -> do + buffers <- allBuffers + mapM_ (\buf -> lift$sourceViewSetShowLineNumbers (sourceView buf) b) buffers) + , mkFieldPP + (paraName <<<- ParaName "TextView Font" $ emptyParams) + (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s)) + (do str <- stringParser + return (if null str then Nothing else Just (str))) + textviewFont + (\ b a -> a{textviewFont = b}) + fontEditor + (\mbs -> do + buffers <- allBuffers + fdesc <- lift $fontDescriptionFromString (case mbs of Just str -> str; Nothing -> "") + lift $mapM_ (\buf -> widgetModifyFont (castToWidget $sourceView buf) (Just fdesc)) buffers) + , mkFieldPP + (paraName <<<- ParaName "Right margin" + $ paraSynopsis <<<- ParaSynopsis "Size or 0 for no right margin" + $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams) + (\a -> (PP.text . show) (case a of Nothing -> 0; Just i -> i)) + (do i <- intParser + return (if i == 0 then Nothing else Just i)) + rightMargin + (\b a -> a{rightMargin = b}) + (maybeEditor (intEditor (1.0, 200.0, 5.0), paraName <<<- ParaName "Position" + $ emptyParams) + True "Show it ?") + (\b -> do + buffers <- allBuffers + mapM_ (\buf -> case b of + Just n -> do + lift $sourceViewSetMargin (sourceView buf) n + lift $sourceViewSetShowMargin (sourceView buf) True + Nothing -> lift $sourceViewSetShowMargin (sourceView buf) False) + buffers) + , mkFieldPP + (paraName <<<- ParaName "Tab width" $ emptyParams) + (PP.text . show) + intParser + tabWidth + (\b a -> a{tabWidth = b}) + (intEditor (1.0, 20.0, 1.0)) + (\i -> do + buffers <- allBuffers + mapM_ (\buf -> lift $sourceViewSetTabsWidth (sourceView buf) i) buffers) + , mkFieldPP + (paraName <<<- ParaName "Use standard line ends even on windows" $ emptyParams) + (PP.text . show) + boolParser + forceLineEnds + (\b a -> a{forceLineEnds = b}) + boolEditor + (\i -> return ()) + , mkFieldPP + (paraName <<<- ParaName "Source candy" + $ paraSynopsis <<<- ParaSynopsis + "Empty for do not use or the name of a candy file in a config dir" + $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams) + (\a -> PP.text (case a of Nothing -> ""; Just s -> s)) + (do id <- identifier + return (if null id then Nothing else Just (id))) + sourceCandy (\b a -> a{sourceCandy = b}) + (maybeEditor (stringEditor, paraName <<<- ParaName "Candy specification" + $ emptyParams) + True "Use it ?") + (\cs -> case cs of + Nothing -> do + setCandyState False + editCandy + Just name -> do + setCandyState True + editCandy) + , mkFieldPP + (paraName <<<- ParaName "Name of the keymap" + $ paraSynopsis <<<- ParaSynopsis + "The name of a keymap file in a config dir" + $ paraDirection <<<- ParaDirection Horizontal $ emptyParams) + PP.text + identifier + keymapName + (\b a -> a{keymapName = b}) + stringEditor + (\ a -> return ()) + ]), + ("Other", [ + mkFieldPP + (paraName <<<- ParaName "LogView Font" $ emptyParams) + (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s)) + (do str <- stringParser + return (if null str then Nothing else Just (str))) + logviewFont + (\ b a -> a{logviewFont = b}) + fontEditor + (\mbs -> do + buffer <- getLog + fdesc <- lift $fontDescriptionFromString (case mbs of Just str -> str; Nothing -> "") + lift $widgetModifyFont (castToWidget $textView buffer) (Just fdesc)) + , mkFieldPP + (paraName <<<- ParaName "Window default size" + $ paraSynopsis <<<- ParaSynopsis + "Default size of the main ide window specified as pair (int,int)" + $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams) + (PP.text.show) + (pairParser intParser) + defaultSize (\(c,d) a -> a{defaultSize = (c,d)}) + (pairEditor ((intEditor (0.0, 3000.0, 25.0)), + paraName <<<- ParaName "X" $ emptyParams) + ((intEditor (0.0, 3000.0, 25.0)), + paraName <<<- ParaName "Y" $ emptyParams)) + (\a -> return ()) + , mkFieldPP + (paraName <<<- ParaName "Browser" $ emptyParams) + (PP.text . show) + stringParser + browser + (\b a -> a{browser = b}) + stringEditor + (\i -> return ()) + , mkFieldPP + (paraName <<<- ParaName "Standard source editor path" $ emptyParams) + (PP.text . show) + readParser + sourcePanePath + (\b a -> a{sourcePanePath = b}) + panePathEditor + (\i -> return ()) + , mkFieldPP + (paraName <<<- ParaName + "Paths under which haskell sources for packages may be found" $ emptyParams) + (PP.text . show) + readParser + sourceDirectories + (\b a -> a{sourceDirectories = b}) + (filesEditor Nothing FileChooserActionSelectFolder "Select folder") + (\i -> return ()) + , mkFieldPP + (paraName <<<- ParaName + "Packages which are excluded from the modules pane" $ emptyParams) + (PP.text . show) + readParser + packageBlacklist + (\b a -> a{packageBlacklist = b}) + dependenciesEditor + (\i -> return ()) + ])] + +instance Default PackageIdentifier where + getDefault = case toPackageIdentifier "unknown-0" of + Nothing -> throwIDE "Preferences.getDefault: Can't parse Package Identifier" + Just it -> it + +defaultPrefs = Prefs { + showLineNumbers = True + , rightMargin = Just 100 + , tabWidth = 4 + , sourceCandy = Just("Default") + , keymapName = "Default" + , forceLineEnds = True + , textviewFont = Nothing + , logviewFont = Nothing + , defaultSize = (1024,800) + , browser = "firefox" + , sourcePanePath = LeftTop + , logPanePath = RightBottom + , infoPanePath = RightBottom + , modulesPanePath = RightTop + , controlPanePath = RightTop + , sourceDirectories = ["C:/ghc","C:/cygwin/home/Nicklisch-Franken/collect"] + , packageBlacklist = [] + } + +-- ------------------------------------------------------------ +-- * Parsing +-- ------------------------------------------------------------ + +readPrefs :: FilePath -> IO Prefs +readPrefs fn = do + res <- P.parseFromFile (prefsParser defaultPrefs (concatMap snd prefsDescription)) fn + case res of + Left pe -> throwIDE $"Error reading prefs file " ++ show fn ++ " " ++ show pe + Right r -> return r + +prefsParser :: a -> [FieldDescriptionPP a] -> P.CharParser () a +prefsParser def descriptions = + let parsersF = map fieldParser descriptions in do + whiteSpace + res <- applyFieldParsers def parsersF + return res + P. "prefs parser" + +-- ------------------------------------------------------------ +-- * Printing +-- ------------------------------------------------------------ + +writePrefs :: FilePath -> Prefs -> IO () +writePrefs fpath prefs = writeFile fpath (showPrefs prefs (concatMap snd prefsDescription)) + +showPrefs :: a -> [FieldDescriptionPP a] -> String +showPrefs prefs prefsDesc = PP.render $ + foldl (\ doc (FDPP _ printer _ _ _) -> doc PP.$+$ printer prefs) PP.empty prefsDesc + + +-- ------------------------------------------------------------ +-- * Editing +-- ------------------------------------------------------------ + +editPrefs :: IDEAction +editPrefs = do + ideR <- ask + p <- readIDE prefs + lift $editPrefs' p prefsDescription ideR + + +editPrefs' :: Prefs -> [(String,[FieldDescriptionPP Prefs])] -> IDERef -> IO () +editPrefs' prefs prefsDesc ideR = do + let flatPrefsDesc = concatMap snd prefsDesc + lastAppliedPrefsRef <- newIORef prefs + dialog <- windowNew + vb <- vBoxNew False 0 + bb <- hButtonBoxNew + apply <- buttonNewFromStock "gtk-apply" + restore <- buttonNewFromStock "Restore" + ok <- buttonNewFromStock "gtk-ok" + cancel <- buttonNewFromStock "gtk-cancel" + boxPackStart bb apply PackNatural 0 + boxPackStart bb restore PackNatural 0 + boxPackStart bb ok PackNatural 0 + boxPackStart bb cancel PackNatural 0 + nb <- newNotebook + notebookSetTabPos nb PosTop + res <- mapM + (\ (tabLabel, partPrefsDesc) -> do + resList <- mapM (\ fd -> (fieldEditor fd) prefs) partPrefsDesc + let (widgetsP, setInjsP, getExtsP,notifiersP) = unzip4 resList + nbbox <- vBoxNew False 0 + mapM_ (\ w -> boxPackStart nbbox w PackNatural 0) widgetsP + sw <- scrolledWindowNew Nothing Nothing + scrolledWindowAddWithViewport sw nbbox + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + notebookAppendPage nb sw tabLabel + return (widgetsP, setInjsP, getExtsP, notifiersP)) + prefsDesc + let (widgets, setInjs, getExts, notifiers) = + foldl (\ (w,i,e,n) (w2,i2,e2,n2) -> (w ++ w2, i ++ i2, e ++ e2, n ++ n2)) ([],[],[],[]) res + let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of + Just s -> s + Nothing -> "Unnamed") flatPrefsDesc + ok `onClicked` (do + mbNewPrefs <- extractAndValidate prefs getExts fieldNames + case mbNewPrefs of + Nothing -> return () + Just newPrefs -> do + lastAppliedPrefs <- readIORef lastAppliedPrefsRef + mapM_ (\ (FDPP _ _ _ _ applyF) -> runReaderT (applyF newPrefs lastAppliedPrefs) ideR) flatPrefsDesc + fp <- getConfigFilePathForSave "Default.prefs" + writePrefs fp newPrefs + runReaderT (modifyIDE_ (\ide -> return (ide{prefs = newPrefs}))) ideR + widgetDestroy dialog + mainQuit) + apply `onClicked` (do + mbNewPrefs <- extractAndValidate prefs getExts fieldNames + case mbNewPrefs of + Nothing -> return () + Just newPrefs -> do + lastAppliedPrefs <- readIORef lastAppliedPrefsRef + mapM_ (\ (FDPP _ _ _ _ applyF) -> runReaderT (applyF newPrefs lastAppliedPrefs) ideR) flatPrefsDesc + writeIORef lastAppliedPrefsRef newPrefs) + restore `onClicked` (do + lastAppliedPrefs <- readIORef lastAppliedPrefsRef + mapM_ (\ (FDPP _ _ _ _ applyF) -> runReaderT (applyF prefs lastAppliedPrefs) ideR) flatPrefsDesc + mapM_ (\ setInj -> setInj prefs) setInjs + writeIORef lastAppliedPrefsRef prefs) + cancel `onClicked` (do + lastAppliedPrefs <- readIORef lastAppliedPrefsRef + mapM_ (\ (FDPP _ _ _ _ applyF) -> runReaderT (applyF prefs lastAppliedPrefs) ideR) flatPrefsDesc + widgetDestroy dialog + mainQuit) + dialog `onDelete` (\_ -> do + widgetDestroy dialog + mainQuit + return True) + boxPackStart vb nb PackGrow 7 + boxPackEnd vb bb PackNatural 7 + containerAdd dialog vb + widgetSetSizeRequest dialog 500 700 + widgetShowAll dialog + mainGUI + return () + + + diff --git a/src/IDE/PrinterParser.hs b/src/IDE/PrinterParser.hs new file mode 100644 --- /dev/null +++ b/src/IDE/PrinterParser.hs @@ -0,0 +1,167 @@ +-- +-- | Module for saving and restoring preferences +-- + +module IDE.PrinterParser ( + + Printer +, Parser +, FieldDescriptionS(..) +, MkFieldDescriptionS +, mkFieldS + +, applyFieldParsers +, boolParser +, intParser +, lineParser +, pairParser +, identifier +, emptyParser +, whiteSpace +, stringParser +, readParser + +, emptyPrinter +, symbol +, colon + + +) where + +import Graphics.UI.Gtk() -- Instances only +import Text.ParserCombinators.Parsec.Language +import qualified Text.ParserCombinators.Parsec.Token as P +import Text.ParserCombinators.Parsec hiding(Parser) +import qualified Text.PrettyPrint.HughesPJ as PP + +import IDE.Framework.Parameters +import IDE.Framework.EditorBasics + + +type Printer beta = beta -> PP.Doc +type Parser beta = CharParser () beta + +-- ------------------------------------------------------------ +-- * Parsing with Parsec +-- ------------------------------------------------------------ + +data FieldDescriptionS alpha = FDS { + parameters :: Parameters + , fieldPrinter :: alpha -> PP.Doc + , fieldParser :: alpha -> CharParser () alpha + } + +type MkFieldDescriptionS alpha beta = + Parameters -> + (Printer beta) -> + (Parser beta) -> + (Getter alpha beta) -> + (Setter alpha beta) -> + FieldDescriptionS alpha + +mkFieldS :: {--Eq beta =>--} MkFieldDescriptionS alpha beta +mkFieldS parameter printer parser getter setter = + FDS parameter + (\ dat -> (PP.text (case getParameterPrim paraName parameter of + Nothing -> "" + Just str -> str) PP.<> PP.colon) + PP.$$ (PP.nest 15 (printer (getter dat))) + PP.$$ (PP.nest 5 (case getParameterPrim paraSynopsis parameter of + Nothing -> PP.empty + Just str -> PP.text $"--" ++ str))) + (\ dat -> try (do + symbol (case getParameterPrim paraName parameter of + Nothing -> "" + Just str -> str) + colon + val <- parser + return (setter val dat))) + +applyFieldParsers :: a -> [a -> CharParser () a] -> CharParser () a +applyFieldParsers prefs parseF = do + let parsers = map (\a -> a prefs) parseF + newprefs <- choice parsers + whiteSpace + applyFieldParsers newprefs parseF + <|> do + eof + return (prefs) + "field parser" + +boolParser :: CharParser () Bool +boolParser = do + (symbol "True" <|> symbol "true") + return True + <|> do + (symbol "False"<|> symbol "false") + return False + "bool parser" + +readParser :: Read a => CharParser () a +readParser = do + str <- many (noneOf ['\n']) + return (read str) + "read parser" + +pairParser :: CharParser () alpha -> CharParser () (alpha,alpha) +pairParser p2 = do + char '(' + v1 <- p2 + char ',' + v2 <- p2 + char ')' + return (v1,v2) + "pair parser" + +stringParser :: CharParser () String +stringParser = do + char '"' + str <- many (noneOf ['"']) + char '"' + return (str) + "string parser" + +lineParser :: CharParser () String +lineParser = do + str <- many (noneOf ['\n']) + return (str) + "line parser" + + +intParser :: CharParser () Int +intParser = do + i <- integer + return (fromIntegral i) + +emptyParser :: CharParser () () +emptyParser = pzero + +prefsStyle :: P.LanguageDef st +prefsStyle = emptyDef { + P.commentStart = "{-" + , P.commentEnd = "-}" + , P.commentLine = "--" + } + +lexer :: P.TokenParser st +lexer = P.makeTokenParser prefsStyle + +whiteSpace :: CharParser st () +whiteSpace = P.whiteSpace lexer + +symbol :: String -> CharParser st String +symbol = P.symbol lexer + +identifier, colon :: CharParser st String +identifier = P.identifier lexer +colon = P.colon lexer + +integer = P.integer lexer + +-- ------------------------------------------------------------ +-- * Printing +-- ------------------------------------------------------------ + + +emptyPrinter :: () -> PP.Doc +emptyPrinter _ = PP.empty diff --git a/src/IDE/RecoverPanes.hs b/src/IDE/RecoverPanes.hs new file mode 100644 --- /dev/null +++ b/src/IDE/RecoverPanes.hs @@ -0,0 +1,36 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.RecoverPanes +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | +-- +------------------------------------------------------------------------------- +module IDE.RecoverPanes ( + paneStateToIDEState +) where + +import IDE.Core.State +import IDE.Log() +import IDE.SourceEditor() +import IDE.ModulesPane() +import IDE.InfoPane() +import IDE.ToolbarPane() +import IDE.FindPane() +import IDE.ReplacePane() + +paneStateToIDEState :: PaneState -> IDEState +paneStateToIDEState (BufferSt st) = StateC st +paneStateToIDEState (LogSt st) = StateC st +paneStateToIDEState (InfoSt st) = StateC st +paneStateToIDEState (ModulesSt st) = StateC st +paneStateToIDEState (CallersSt st) = StateC st +paneStateToIDEState (ToolbarSt st) = StateC st +paneStateToIDEState (FindSt st) = StateC st +paneStateToIDEState (ReplaceSt st) = StateC st diff --git a/src/IDE/ReplacePane.hs b/src/IDE/ReplacePane.hs new file mode 100644 --- /dev/null +++ b/src/IDE/ReplacePane.hs @@ -0,0 +1,247 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.ReplacePane +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | The pane of ide for replacing text in a text buffer +-- +------------------------------------------------------------------------------- + +module IDE.ReplacePane ( + ReplaceAction(..) +) where + +import Graphics.UI.Gtk hiding (get) +import Data.Maybe +import Control.Monad.Reader +import Data.List +import Data.Char(toUpper) + +import IDE.Core.State +import IDE.Framework.ViewFrame +import IDE.Framework.MakeEditor +import IDE.SourceEditor +import IDE.Framework.Parameters +import IDE.Framework.SimpleEditors +import IDE.Framework.EditorBasics +import IDE.FindPane + + +------------------------------------------------------------------------------- +-- +-- * Interface +-- + +-- +-- | The Replace Pane +-- + +class ReplaceAction alpha where + doReplace :: alpha + +instance ReplaceAction IDEAction where + doReplace = doReplace' + +instance IDEObject IDEReplace + +instance CastablePane IDEReplace where + casting _ = ReplaceCasting + downCast _ (PaneC a) = case casting a of + ReplaceCasting -> Just a + _ -> Nothing + + +instance Recoverable ReplaceState where + toPaneState a = ReplaceSt a + +instance Pane IDEReplace + where + primPaneName _ = "Replace" + getAddedIndex _ = 0 + getTopWidget = castToWidget . replaceBox + paneId b = "*Replace" + makeActive p = throwIDE "don't activate replace bar" + close pane = do + (panePath,_) <- guiPropertiesFromName (paneName pane) + nb <- getNotebook panePath + mbI <- lift $notebookPageNum nb (getTopWidget pane) + case mbI of + Nothing -> lift $ do + sysMessage Normal "notebook page not found: unexpected" + return () + Just i -> do + lift $notebookRemovePage nb i + removePaneAdmin pane + +instance RecoverablePane IDEReplace ReplaceState where + saveState p = do + mbFind <- getPane ReplaceCasting + case mbFind of + Nothing -> return Nothing + Just p -> return Nothing + --lift $ do + --return (Just (StateC ReplaceState)) + recoverState pp st = do + nb <- getNotebook pp + initReplace pp nb st + + +------------------------------------------------------------------------------- +-- +-- * Implementation +-- + +emptyReplaceState = ReplaceState "" "" False False False + +doReplace' :: IDEAction +doReplace' = do + replace <- getReplace + lift $ bringPaneToFront replace + lift $ widgetGrabFocus (replaceBox replace) + +getReplace :: IDEM IDEReplace +getReplace = do + mbReplace <- getPane ReplaceCasting + case mbReplace of + Nothing -> do + prefs <- readIDE prefs + layout <- readIDE layout + let pp = getStandardPanePath (controlPanePath prefs) layout + nb <- getNotebook pp + initReplace pp nb emptyReplaceState + mbReplace <- getPane ReplaceCasting + case mbReplace of + Nothing -> throwIDE "Can't init replace pane" + Just m -> return m + Just m -> return m + +initReplace :: PanePath -> Notebook -> ReplaceState -> IDEAction +initReplace panePath nb replace = do + ideR <- ask + panes <- readIDE panes + paneMap <- readIDE paneMap + prefs <- readIDE prefs + currentInfo <- readIDE currentInfo + (buf,cids) <- lift $ do + vb <- vBoxNew False 0 + hb <- hBoxNew False 0 + bb <- hButtonBoxNew + + replAll <- buttonNewWithMnemonic "Replace _all" + replB <- buttonNewWithMnemonic "_Replace" + find <- buttonNewWithMnemonic "_Find" + + boxPackStart bb find PackNatural 0 + boxPackStart bb replB PackNatural 0 + boxPackStart bb replAll PackNatural 0 + + resList <- mapM (\ fd -> (fieldEditor fd) replace) replaceDescription + let (widgetsP, setInjsP, getExtsP, notifiersP) = unzip4 resList + mapM_ (\ w -> boxPackStart hb w PackNatural 0) widgetsP + let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of + Just s -> s + Nothing -> "Unnamed") replaceDescription + find `onClicked` do + findOrSearch editFind getExtsP fieldNames replB replAll ideR + + replB `onClicked` do + findOrSearch editReplace getExtsP fieldNames replB replAll ideR + + replAll `onClicked` do + findOrSearch editReplaceAll getExtsP fieldNames replB replAll ideR + + boxPackStart vb hb PackNatural 0 + boxPackStart vb bb PackNatural 0 + + let replace = IDEReplace vb + notebookInsertOrdered nb vb (paneName replace) + widgetShowAll vb + return (replace,[]) + addPaneAdmin buf (BufConnections [] [] []) panePath + lift $widgetGrabFocus (replaceBox buf) + where + findOrSearch :: (Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool) + -> [ReplaceState -> Extractor ReplaceState] -> [String] -> Button -> + Button -> IDERef -> IO() + findOrSearch f getExtsP fieldNames replB replAll ideR= do + mbReplaceState <- extractAndValidate replace getExtsP fieldNames + case mbReplaceState of + Nothing -> return () + Just rs -> do + let hint = if searchBackwards rs then Backward else Forward + found <- runReaderT (f (matchEntire rs) (matchCase rs) False + (searchFor rs) (replaceWith rs) hint) ideR + widgetSetSensitivity replB found + widgetSetSensitivity replAll found + return () + +replaceDescription :: [FieldDescription ReplaceState] +replaceDescription = [ + mkField + (paraName <<<- ParaName "Search for" $ emptyParams) + searchFor + (\ b a -> a{searchFor = b}) + stringEditor + , mkField + (paraName <<<- ParaName "Replace with" $ emptyParams) + replaceWith + (\ b a -> a{replaceWith = b}) + stringEditor + , mkField + (paraName <<<- ParaName "Match case" $ emptyParams) + matchCase + (\ b a -> a{matchCase = b}) + boolEditor + , mkField + (paraName <<<- ParaName "Entire word" $ emptyParams) + matchEntire + (\ b a -> a{matchEntire = b}) + boolEditor + , mkField + (paraName <<<- ParaName "Back" $ emptyParams) + searchBackwards + (\ b a -> a{searchBackwards = b}) + boolEditor] + +editReplace :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool +editReplace entireWord caseSensitive wrapAround search replace hint = + editReplace' entireWord caseSensitive wrapAround search replace hint True + +editReplace' :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> Bool -> IDEM Bool +editReplace' entireWord caseSensitive wrapAround search replace hint mayRepeat = + inBufContext' False $ \_ gtkbuf currentBuffer _ -> do + startMark <- lift $textBufferGetInsert gtkbuf + iter <- lift $textBufferGetIterAtMark gtkbuf startMark + iter2 <- lift $textIterCopy iter + lift $textIterForwardChars iter2 (length search) + str1 <- lift $textIterGetText iter iter2 + if compare str1 search caseSensitive + then do + lift $textBufferDelete gtkbuf iter iter2 + lift $textBufferInsert gtkbuf iter replace + editFind entireWord caseSensitive wrapAround search "" hint + else do + r <- editFind entireWord caseSensitive wrapAround search "" hint + if r + then editReplace' entireWord caseSensitive wrapAround search + replace hint False + else return False + where + compare s1 s2 True = s1 == s2 + compare s1 s2 False = map toUpper s1 == map toUpper s2 + +editReplaceAll :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool +editReplaceAll entireWord caseSensitive wrapAround search replace hint = do + res <- editReplace' entireWord caseSensitive wrapAround search replace hint True + if res + then editReplaceAll entireWord caseSensitive wrapAround search replace hint + else return False + + + diff --git a/src/IDE/SaveSession.hs b/src/IDE/SaveSession.hs new file mode 100644 --- /dev/null +++ b/src/IDE/SaveSession.hs @@ -0,0 +1,270 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.SaveSession +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- +-- | Module for saving and recovering the layout +-- +--------------------------------------------------------------------------------- + + +module IDE.SaveSession ( + SaveSessionAction(..) +) where + +import Graphics.UI.Gtk hiding (showLayout) +import Text.ParserCombinators.Parsec hiding(Parser) +import Control.Monad.Reader +import System.FilePath +import qualified Data.Map as Map +import Data.Maybe +--import GHC.Exception (catch) + +import IDE.Core.State +import IDE.Framework.ViewFrame +import IDE.Utils.File +import IDE.PrinterParser +import qualified Text.PrettyPrint.HughesPJ as PP +import IDE.Framework.Parameters +import IDE.Package +import IDE.RecoverPanes + + +instance IDEObject IDEAction + +class IDEObject o => SaveSessionAction o where + saveSession :: o + recoverSession :: o + sessionClosePane :: o + +instance SaveSessionAction IDEAction where + saveSession = saveSession' + recoverSession = recoverSession' + sessionClosePane = sessionClosePane' + + +-- | *Implementation + +sessionClosePane' :: IDEAction +sessionClosePane' = do + activePane' <- readIDE activePane + case activePane' of + Nothing -> return () + Just (pn,_) -> do + p <- paneFromName pn + close p + +sessionFilename = "Current.session" + +data SessionState = SessionState { + layoutS :: PaneLayout + , population :: [(Maybe PaneState,PanePath)] + , windowSize :: (Int,Int) + , activePackage :: Maybe FilePath + , activePaneN :: Maybe String +} deriving() + +defaultLayout = SessionState { + layoutS = TerminalP (Just TopP) (-1) + , population = [] + , windowSize = (1024,768) + , activePackage = Nothing + , activePaneN = Nothing} + +layoutDescr :: [FieldDescriptionS SessionState] +layoutDescr = [ + mkFieldS + (paraName <<<- ParaName "Layout" $ emptyParams) + (PP.text . show) + readParser + layoutS + (\ b a -> a{layoutS = b}) + , mkFieldS + (paraName <<<- ParaName "Population" $ emptyParams) + (PP.text . show) + readParser + population + (\ b a -> a{population = b}) + , mkFieldS + (paraName <<<- ParaName "Window size" $ emptyParams) + (PP.text . show) + (pairParser intParser) + windowSize + (\(c,d) a -> a{windowSize = (c,d)}) + , mkFieldS + (paraName <<<- ParaName "Active package" $ emptyParams) + (PP.text . show) + readParser + activePackage + (\fp a -> a{activePackage = fp}) + , mkFieldS + (paraName <<<- ParaName "Active pane" $ emptyParams) + (PP.text . show) + readParser + activePaneN + (\fp a -> a{activePaneN = fp})] + +-- +-- | Get and save the current layout +-- +saveSession' :: IDEAction +saveSession' = do + ideMessage Normal "Now saving session" + wdw <- readIDE window + layout <- getLayout + population <- getPopulation + layoutPath <- lift $getConfigFilePathForSave sessionFilename + size <- lift $windowGetSize wdw + active <- getActive + activePane' <- readIDE activePane + let activeP = case activePane' of + Nothing -> Nothing + Just (s,_) -> Just s + lift $writeLayout layoutPath $SessionState layout population size active activeP + +writeLayout :: FilePath -> SessionState -> IO () +writeLayout fpath ls = writeFile fpath (showLayout ls layoutDescr) + +showLayout :: a -> [FieldDescriptionS a] -> String +showLayout prefs prefsDesc = PP.render $ + foldl (\ doc (FDS _ printer _) -> doc PP.$+$ printer prefs) PP.empty prefsDesc + +getLayout :: IDEM(PaneLayout) +getLayout = do + rawLayout <- readIDE layout + getLayout' rawLayout [] + where + getLayout' (HorizontalP l r _) pp = do + l2 <- getLayout' l (pp ++ [TopP]) + r2 <- getLayout' r (pp ++ [BottomP]) + pane <- getPaned pp + pos <- lift $ panedGetPosition pane + return (HorizontalP l2 r2 pos) + getLayout' (VerticalP l r _) pp = do + l2 <- getLayout' l (pp ++ [LeftP]) + r2 <- getLayout' r (pp ++ [RightP]) + pane <- getPaned pp + pos <- lift $ panedGetPosition pane + return (VerticalP l2 r2 pos) + getLayout' (TerminalP _ _) pp = do + nb <- getNotebook pp + showTabs <- lift $ notebookGetShowTabs nb + pos <- lift $ notebookGetTabPos nb + current <- lift $ notebookGetCurrentPage nb + return (TerminalP (if showTabs + then Just (posTypeToPaneDirection pos) + else Nothing) current) + +getPopulation :: IDEM[(Maybe PaneState,PanePath)] +getPopulation = do + paneMap <- readIDE paneMap + mapM (\ (pn,v) -> do + p <- paneFromName pn + mbSt <- saveState p + let st = case mbSt of + Nothing -> Nothing + Just s -> Just (toPaneState s) + return (st, fst v)) + $Map.toList paneMap + +getActive :: IDEM(Maybe String) +getActive = do + active <- readIDE activePack + case active of + Nothing -> return Nothing + Just p -> return (Just (cabalFile p)) + +-- ------------------------------------------------------------ +-- * Parsing +-- ------------------------------------------------------------ + +-- +-- | Read and apply the saved layout +-- + +recoverSession' :: IDEAction +recoverSession' = do + wdw <- readIDE window + layoutSt <- lift$ readLayout + lift $windowSetDefaultSize wdw (fst (windowSize layoutSt))(snd (windowSize layoutSt)) + applyLayout (layoutS layoutSt) + case activePackage layoutSt of + Just fp -> activatePackage fp >> return () + Nothing -> return () + populate (population layoutSt) + setCurrentPages (layoutS layoutSt) + when (isJust (activePaneN layoutSt)) $ do + mbPane <- mbPaneFromName (fromJust (activePaneN layoutSt)) + when (isJust mbPane) $ + makeActive (fromJust mbPane) + +readLayout :: IO SessionState +readLayout = do + layoutPath <- getConfigFilePathForLoad sessionFilename + res <- parseFromFile (prefsParser defaultLayout layoutDescr) layoutPath + case res of + Left pe -> throwIDE $"Error reading prefs file " ++ show layoutPath ++ " " ++ show pe + Right r -> return r + +prefsParser :: a -> [FieldDescriptionS a] -> CharParser () a +prefsParser def descriptions = + let parsersF = map fieldParser descriptions in do + whiteSpace + applyFieldParsers def parsersF + "layout parser" + +applyLayout :: PaneLayout -> IDEAction +applyLayout layoutS = do + old <- readIDE layout + case old of + TerminalP _ _ -> applyLayout' layoutS [] + otherwise -> throwIDE "apply Layout can only be allied to empty Layout" + where + applyLayout' (TerminalP Nothing _) pp = do + nb <- getNotebook pp + lift $notebookSetShowTabs nb False + applyLayout' (TerminalP (Just p) _) pp = do + nb <- getNotebook pp + lift $notebookSetShowTabs nb True + lift $notebookSetTabPos nb (paneDirectionToPosType p) + applyLayout' (VerticalP l r pos) pp = do + viewSplit' pp Vertical + pane <- getPaned pp + lift $panedSetPosition pane pos + applyLayout' l (pp ++ [LeftP]) + applyLayout' r (pp ++ [RightP]) + applyLayout' (HorizontalP t b pos) pp = do + viewSplit' pp Horizontal + pane <- getPaned pp + lift $panedSetPosition pane pos + applyLayout' t (pp ++ [TopP]) + applyLayout' b (pp ++ [BottomP]) + +populate :: [(Maybe PaneState,PanePath)] -> IDEAction +populate = mapM_ (\ (mbPs,pp) -> + case mbPs of + Nothing -> return () + Just s -> recoverState pp (paneStateToIDEState s)) + +setCurrentPages :: PaneLayout -> IDEAction +setCurrentPages layout = setCurrentPages' layout [] + where + setCurrentPages' (HorizontalP t b _) p = do setCurrentPages' t (TopP : p) + setCurrentPages' b (BottomP : p) + setCurrentPages' (VerticalP l r _) p = do setCurrentPages' l (LeftP : p) + setCurrentPages' r (RightP : p) + setCurrentPages' (TerminalP _ ind) p = when (ind > 0) $ do + nb <- getNotebook (reverse p) + lift $ notebookSetCurrentPage nb ind + + + + + diff --git a/src/IDE/SourceCandy.hs b/src/IDE/SourceCandy.hs new file mode 100644 --- /dev/null +++ b/src/IDE/SourceCandy.hs @@ -0,0 +1,274 @@ +----------------------------------------------------------------------------- +-- +-- Module : IDE.SourceCandy +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- +-- | +-- +--------------------------------------------------------------------------------- + +module IDE.SourceCandy ( + SourceCandy(..) +) where + +import Data.Char(chr) +import Data.List(isSuffixOf) +import Graphics.UI.Gtk +import Graphics.UI.Gtk.SourceView.SourceBuffer +import Control.Monad.Reader +import Text.ParserCombinators.Parsec +import qualified Text.ParserCombinators.Parsec.Token as P +import Text.ParserCombinators.Parsec.Language(emptyDef) +import qualified Data.Set as Set + +import IDE.Core.State + +--------------------------------------------------------------------------------- +-- * Interface + +class IDEObject alpha => SourceCandy alpha where + parseCandy :: FilePath -> IO alpha + transformToCandy :: alpha -> TextBuffer -> IO () + transformFromCandy :: alpha -> TextBuffer -> IO () + keystrokeCandy :: alpha -> Maybe Char -> TextBuffer -> IO () + getCandylessText :: alpha -> TextBuffer -> IO String + +instance IDEObject CandyTable + +instance SourceCandy CandyTable where + parseCandy = parseCandy' + transformToCandy = transformToCandy' + transformFromCandy = transformFromCandy' + keystrokeCandy = keystrokeCandy' + getCandylessText = getCandylessText' + +--------------------------------------------------------------------------------- +-- * Implementation + +notBeforeId = Set.fromList $['a'..'z'] ++ ['A'..'Z'] ++ ['_'] +notAfterId = Set.fromList $['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['_'] +notBeforeOp = Set.fromList $['!','#','$','%','&','*','+','.','/','<','=','>','?','@','\\', + '^','|','-','~','\'','"'] +notAfterOp = notBeforeOp + +keystrokeCandy' :: CandyTable -> Maybe Char -> TextBuffer -> IO () +keystrokeCandy' (CT(transformTable,_)) mbc gtkbuf = do + cursorMark <- textBufferGetInsert gtkbuf + endIter <- textBufferGetIterAtMark gtkbuf cursorMark + offset <- textIterGetOffset endIter + let sliceStart = if offset < 8 then 0 else offset - 8 + startIter <- textBufferGetIterAtOffset gtkbuf sliceStart + slice <- textIterGetSlice startIter endIter + mbc2 <- case mbc of + Just c -> return (Just c) + Nothing -> do + isEnd <- textIterIsEnd endIter + if isEnd + then (return Nothing) + else do + textIterForwardChar endIter + textIterGetChar endIter + replace mbc2 cursorMark slice offset transformTable + where + replace :: Maybe Char -> TextMark -> String -> Int -> [(Bool,String,String)] -> IO () + replace mbAfterChar cursorMark match offset list = replace' list + where + replace' [] = return () + replace' ((isOp,from,to):rest) = + let beforeChar = match !! (max 0 (length match - (length from + 1))) + beforeOk = not $if isOp + then Set.member beforeChar notBeforeOp + else Set.member beforeChar notBeforeId + afterOk = case mbAfterChar of + Nothing -> True + Just afterChar -> + not $if isOp + then Set.member afterChar notAfterOp + else Set.member afterChar notAfterId + in if isSuffixOf from match && beforeOk && afterOk + then do + sourceBufferBeginNotUndoableAction (castToSourceBuffer gtkbuf) + start <- textBufferGetIterAtOffset gtkbuf (offset - (length from)) + end <- textBufferGetIterAtOffset gtkbuf offset + textBufferDelete gtkbuf start end + ins <- textBufferGetIterAtMark gtkbuf cursorMark + textBufferInsert gtkbuf ins to + sourceBufferEndNotUndoableAction (castToSourceBuffer gtkbuf) + else replace mbAfterChar cursorMark match offset rest + +transformToCandy' :: CandyTable -> TextBuffer -> IO () +transformToCandy' (CT(transformTable,_)) gtkbuf = do + textBufferBeginUserAction gtkbuf + modified <- textBufferGetModified gtkbuf + mapM_ (\tbl -> replaceTo gtkbuf tbl 0) transformTable + textBufferSetModified gtkbuf modified + textBufferEndUserAction gtkbuf + + +replaceTo :: TextBuffer -> (Bool,String,String) -> Int -> IO () +replaceTo buf (isOp,from,to) offset = replaceTo' offset + where + replaceTo' offset = do + iter <- textBufferGetIterAtOffset buf offset + mbStartEnd <- textIterForwardSearch iter from [] Nothing + case mbStartEnd of + Nothing -> return () + Just (st,end) -> do + stOff <- textIterGetOffset st + beforeOk <- + if stOff == 0 + then return True + else do + iter <- textBufferGetIterAtOffset buf (stOff - 1) + mbChar <- textIterGetChar iter + case mbChar of + Nothing -> return True + Just char -> return (not $if isOp + then Set.member char notBeforeOp + else Set.member char notBeforeId) + if beforeOk + then do + afterOk <- do + endOff <- textIterGetOffset end + iter <- textBufferGetIterAtOffset buf endOff + mbChar <- textIterGetChar iter + case mbChar of + Nothing -> return True + Just char -> return (not $if isOp + then Set.member char notAfterOp + else Set.member char notAfterId) + if afterOk + then do + textBufferDelete buf st end + textBufferInsert buf st to + return () + else do + return () + else do + return () + replaceTo' (stOff + 1) + +transformFromCandy' :: CandyTable -> TextBuffer -> IO () +transformFromCandy' (CT(_,transformTableBack)) gtkbuf = do + textBufferBeginUserAction gtkbuf + modified <- textBufferGetModified gtkbuf + mapM_ (\tbl -> replaceFrom gtkbuf tbl 0) transformTableBack + textBufferEndUserAction gtkbuf + textBufferSetModified gtkbuf modified + +getCandylessText' :: CandyTable -> TextBuffer -> IO (String) +getCandylessText' (CT(_,transformTableBack)) gtkbuf = do + workBuffer <- textBufferNew Nothing + i1 <- textBufferGetStartIter gtkbuf + i2 <- textBufferGetEndIter gtkbuf + text <- textBufferGetText gtkbuf i1 i2 True + textBufferSetText workBuffer text + mapM_ (\tbl -> replaceFrom workBuffer tbl 0) transformTableBack + i1 <- textBufferGetStartIter workBuffer + i2 <- textBufferGetEndIter workBuffer + text <- textBufferGetText workBuffer i1 i2 True + return text + +replaceFrom :: TextBuffer -> (String,String,Int) -> Int -> IO () +replaceFrom buf (to,from,spaces) offset = replaceFrom' offset + where + replaceFrom' offset = do + iter <- textBufferGetIterAtOffset buf offset + mbStartEnd <- textIterForwardSearch iter from [] Nothing + case mbStartEnd of + Nothing -> return () + Just (st,end) -> do + offset <- textIterGetOffset st + textBufferDelete buf st end + if spaces > 0 + then do + iter2 <- textBufferGetIterAtOffset buf offset + iter3 <- textBufferGetIterAtOffset buf (offset + spaces + 1) + slice <- textIterGetSlice iter2 iter3 + let l = length (takeWhile (== ' ') slice) + if l > 1 + then do + textIterSetOffset iter3 (offset + l - 1) + textBufferDelete buf iter2 iter3 + else return () + else return () + iter <- textBufferGetIterAtOffset buf offset + textBufferInsert buf iter to + replaceFrom' offset + +type CandyTableI = [(String,Char,Bool)] + +forthFromTable :: CandyTableI -> CandyTableForth +forthFromTable table = map forthFrom table + where + forthFrom (str,chr,noTrimming) = + let isOp = not (Set.member (head str) notBeforeId) + from = str + trailingBlanks = replicate (if noTrimming then 0 else length str - 1) ' ' + to = [chr] ++ trailingBlanks + in (isOp,from,to) + +backFromTable :: CandyTableI -> CandyTableBack +backFromTable table = map backFrom table + where + backFrom (str,chr,noTrimming) = + let numTrailingBlanks = if noTrimming then 0 else length str - 1 + in (str,[chr],numTrailingBlanks) + +---Candy Parser + +candyStyle :: P.LanguageDef st +candyStyle = emptyDef + { P.commentStart = "{-" + , P.commentEnd = "-}" + , P.commentLine = "--" + } + +lexer = P.makeTokenParser candyStyle +lexeme = P.lexeme lexer +whiteSpace = P.whiteSpace lexer +hexadecimal = P.hexadecimal lexer +symbol = P.symbol lexer + +parseCandy' :: FilePath -> IO CandyTable +parseCandy' fn = do + res <- parseFromFile candyParser fn + case res of + Left pe -> throwIDE $"Error reading keymap file " ++ show fn ++ " " ++ show pe + Right r -> return (CT(forthFromTable r, backFromTable r)) + +candyParser :: CharParser () CandyTableI +candyParser = do + whiteSpace + ls <- many oneCandyParser + eof + return ls + +oneCandyParser :: CharParser () (String,Char,Bool) +oneCandyParser = do + toReplace <- toReplaceParser + replaceWith <- replaceWithParser + nt <- option True (try $do + symbol "Trimming" + return False) + return (toReplace,replaceWith,nt) + +toReplaceParser :: CharParser () String +toReplaceParser = lexeme (do + str <- between (char '"') + (char '"' "end of string") + (many $noneOf "\"") + return str) + "to replace string" + +replaceWithParser :: CharParser () Char +replaceWithParser = do + char '0' + hd <- lexeme hexadecimal + return (chr (fromIntegral hd)) diff --git a/src/IDE/SourceEditor.hs b/src/IDE/SourceEditor.hs new file mode 100644 --- /dev/null +++ b/src/IDE/SourceEditor.hs @@ -0,0 +1,894 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.SourceEditor +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | The source editor part of Leksah +-- +----------------------------------------------------------------------------------- + +module IDE.SourceEditor ( + allBuffers +, maybeActiveBuf +, standardSourcePanePath +, selectSourceBuf +, goToSourceDefinition +, goToDefinition + +, newTextBuffer + +, fileNew +, fileOpen +, fileRevert +, fileClose +, fileCloseAll +, fileCloseAllButPackage +, fileSave +, editUndo +, editRedo +, editCut +, editCopy +, editPaste +, editDelete +, editSelectAll + +, editComment +, editUncomment +, editShiftRight +, editShiftLeft + +, editToCandy +, editFromCandy +, editKeystrokeCandy +, editCandy + +, markErrorInSourceBuf +, inBufContext' +, inBufContext +) where + +import Graphics.UI.Gtk hiding (afterToggleOverwrite) +import Graphics.UI.Gtk.SourceView +import Graphics.UI.Gtk.Multiline.TextView +import Control.Monad.Reader +--import Data.IORef +import System.IO +import System.FilePath +import System.Directory +import Text.Printf +import qualified Data.Map as Map +import Data.List +import Data.Maybe + +import IDE.Core.State +import IDE.Utils.File +import IDE.Framework.ViewFrame +import IDE.SourceCandy + +instance IDEObject IDEBuffer +instance Pane IDEBuffer + where + primPaneName = bufferName + getAddedIndex = addedIndex + getTopWidget = castToWidget . scrolledWindow + paneId b = case fileName b of + Just s -> s + Nothing -> "?" ++ bufferName b + makeActive buf = do + pane <- paneFromName (paneName buf) + if isIt BufferCasting pane + then do + let actbuf = fromJust $ downCast BufferCasting pane + ideR <- ask + sbLC <- getStatusbarLC + sbIO <- getStatusbarIO + infos <- readIDE accessibleInfo + let sv = sourceView actbuf + (tl,tm,tr) <- lift $do + gtkBuf <- textViewGetBuffer sv + bringPaneToFront actbuf + writeCursorPositionInStatusbar sv sbLC + writeOverwriteInStatusbar sv sbIO + id1 <- gtkBuf `afterModifiedChanged` runReaderT (markLabelAsChanged) ideR + id2 <- sv `afterMoveCursor` + (\_ _ _ -> writeCursorPositionInStatusbar sv sbLC) + id3 <- gtkBuf `afterEndUserAction` writeCursorPositionInStatusbar sv sbLC + sv `widgetAddEvents` [ButtonReleaseMask] + id4 <- sv `onButtonRelease` (\ _ -> do + writeCursorPositionInStatusbar sv sbLC + return False) + id5 <- sv `onButtonRelease` (\ e -> do + showInfo sv ideR + return False) + id6 <- sv `afterToggleOverwrite` writeOverwriteInStatusbar sv sbIO + return ([id2,id4,id6],[id1,id3],[]) + activatePane actbuf (BufConnections tl tm tr) + checkModTime actbuf + else return () + close pane = do makeActive pane + fileClose + return () + +instance RecoverablePane IDEBuffer BufferState where + saveState p = do buf <- lift $ textViewGetBuffer (sourceView p) + ins <- lift $ textBufferGetInsert buf + iter <- lift $ textBufferGetIterAtMark buf ins + offset <- lift $ textIterGetOffset iter + case fileName p of + Nothing -> return Nothing + Just fn -> return (Just (StateC (BufferState fn offset))) + recoverState pp (BufferState n i) = do + exists <- lift $doesFileExist n + when exists $ do + buf <- newTextBuffer pp (takeFileName n) (Just n) + lift $ do + gtkBuf <- textViewGetBuffer (sourceView buf) + iter <- textBufferGetIterAtOffset gtkBuf i + textBufferPlaceCursor gtkBuf iter + mark <- textBufferGetInsert gtkBuf + textViewScrollToMark (sourceView buf) mark 0.0 (Just (0.3,0.3)) + return () + +selectSourceBuf :: FilePath -> IDEM Bool +selectSourceBuf fp = do + fpc <- lift $canonicalizePath fp + buffers <- allBuffers + let buf = filter (\b -> case fileName b of + Just fn -> equalFilePath fn fpc + Nothing -> False) buffers + case buf of + hdb:tl -> do + makeActive hdb + return True + otherwise -> do + fe <- lift $doesFileExist fpc + if fe + then do + path <- standardSourcePanePath + newTextBuffer path (takeFileName fpc) (Just fpc) + return True + else return False + +goToDefinition :: IdentifierDescr -> IDEAction +goToDefinition idDescr = do + mbAccesibleInfo <- readIDE accessibleInfo + mbCurrentInfo <- readIDE currentInfo + if isJust mbAccesibleInfo && isJust mbCurrentInfo + then do + let packageId = pack $ moduleIdID idDescr + let mbPack = case packageId `Map.lookup` fst + (fromJust mbAccesibleInfo) of + Just it -> Just it + Nothing -> packageId `Map.lookup` fst (fst + (fromJust mbCurrentInfo)) + case mbPack of + Just pack -> case filter (\md -> moduleIdMD md == moduleIdID idDescr) + (exposedModulesPD pack) of + [mod] -> if isJust (mbSourcePathMD mod) + then goToSourceDefinition + (fromJust $ mbSourcePathMD mod) + (mbLocation idDescr) + else return () + _ -> ideMessage Normal "not just one module" + Nothing -> do ideMessage Normal "no package" + else ideMessage Normal "no infos" + +goToSourceDefinition :: FilePath -> Maybe Location -> IDEAction +goToSourceDefinition fp mbLocation = do + success <- selectSourceBuf fp + when (success && isJust mbLocation) $ + inBufContext () $ \_ gtkbuf buf _ -> do + let location = fromJust mbLocation + lines <- textBufferGetLineCount gtkbuf + iter <- textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1) + ((locationSLine location) -1))) + chars <- textIterGetCharsInLine iter + textIterSetLineOffset iter (max 0 (min (chars-1) (locationSCol location))) + iter2 <- textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1) + ((locationELine location) -1))) + chars2 <- textIterGetCharsInLine iter2 + textIterSetLineOffset iter2 (max 0 (min (chars2-1) (locationECol location))) + textBufferPlaceCursor gtkbuf iter + smark <- textBufferGetSelectionBound gtkbuf + textBufferMoveMark gtkbuf smark iter2 + + imark <- textBufferGetInsert gtkbuf + -- ### we have a problem here that this does not work for a frsh opened buffer + textViewScrollToMark (sourceView buf) imark 0.0 (Just (0.3,0.3)) + + +markErrorInSourceBuf :: Int -> Int -> String -> IDEAction +markErrorInSourceBuf line column string = + inBufContext () $ \_ gtkbuf buf _ -> do + i1 <- textBufferGetStartIter gtkbuf + i2 <- textBufferGetEndIter gtkbuf + textBufferRemoveTagByName gtkbuf "activeErr" i1 i2 + + lines <- textBufferGetLineCount gtkbuf + iter <- textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1) (line-1))) + chars <- textIterGetCharsInLine iter + textIterSetLineOffset iter (max 0 (min (chars-1) column)) + iter2 <- textIterCopy iter + textIterForwardWordEnd iter2 + textBufferApplyTagByName gtkbuf "activeErr" iter iter2 + textBufferPlaceCursor gtkbuf iter + mark <- textBufferGetInsert gtkbuf + textViewScrollToMark (sourceView buf) mark 0.0 (Just (0.3,0.3)) + + +allBuffers :: IDEM [IDEBuffer] +allBuffers = do + panesST <- readIDE panes + return (catMaybes $ map (downCast BufferCasting) $ Map.elems panesST) + +maybeActiveBuf :: IDEM (Maybe (IDEBuffer,Connections)) +maybeActiveBuf = do + mbPane <- readIDE activePane + case mbPane of + Nothing -> return Nothing + Just (paneName,signals) -> do + pane <- paneFromName paneName + if isIt BufferCasting pane + then return (Just (fromJust $ downCast BufferCasting pane,signals)) + else return Nothing + +standardSourcePanePath :: IDEM PanePath +standardSourcePanePath = do + layout <- readIDE layout + prefs <- readIDE prefs + return (getStandardPanePath (sourcePanePath prefs) layout) + +newTextBuffer :: PanePath -> String -> Maybe FilePath -> IDEM IDEBuffer +newTextBuffer panePath bn mbfn = do + -- create the appropriate language + ideR <- ask + nb <- getNotebook panePath + panes <- readIDE panes + paneMap <- readIDE paneMap + prefs <- readIDE prefs + bs <- getCandyState + ct <- readIDE candy + let (ind,rbn) = figureOutPaneName panes bn 0 + (buf,cids) <- lift $ do + lm <- sourceLanguagesManagerNew + langM <- sourceLanguagesManagerGetLanguageFromMimeType lm "text/x-haskell" + lang <- case langM of + (Just lang) -> return lang + Nothing -> do + langDirs <- sourceLanguagesManagerGetLangFilesDirs lm + throwIDE ("please copy haskell.lang to one of the following" + ++ "directories:\n" + ++ unlines langDirs) + + -- create a new SourceBuffer object + buffer <- sourceBufferNewWithLanguage lang + tagTable <- textBufferGetTagTable buffer + foundTag <- textTagNew (Just "found") + set foundTag [textTagBackground := "yellow"] + textTagTableAdd tagTable foundTag + activeErrtag <- textTagNew (Just "activeErr") + set activeErrtag[textTagUnderline := UnderlineError] + textTagTableAdd tagTable activeErrtag + + -- load up and display a file + (fileContents,modTime) <- case mbfn of + Just fn -> do + fc <- readFile fn + mt <- getModificationTime fn + return (fc,Just mt) + Nothing -> return ("\n\n\n\n\n",Nothing) + sourceBufferBeginNotUndoableAction buffer + textBufferSetText buffer fileContents + if bs + then transformToCandy ct (castToTextBuffer buffer) + else return () + sourceBufferEndNotUndoableAction buffer + textBufferSetModified buffer False + siter <- textBufferGetStartIter buffer + textBufferPlaceCursor buffer siter + sourceBufferSetHighlight buffer True + iter <- textBufferGetEndIter buffer + textBufferCreateMark buffer (Just "end") iter True + + -- create a new SourceView Widget + sv <- sourceViewNewWithBuffer buffer + fd <- case textviewFont prefs of + Just str -> do + fontDescriptionFromString str + Nothing -> do + f <- fontDescriptionNew + fontDescriptionSetFamily f "Monospace" + return f + widgetModifyFont sv (Just fd) + sourceViewSetShowLineNumbers sv (showLineNumbers prefs) + case rightMargin prefs of + Just n -> do + sourceViewSetMargin sv n + sourceViewSetShowMargin sv True + Nothing -> sourceViewSetShowMargin sv True + sourceViewSetInsertSpacesInsteadOfTabs sv True + sourceViewSetTabsWidth sv (tabWidth prefs) + sourceViewSetSmartHomeEnd sv True + --sourceViewSetShowLineMarkers sv True + + -- put it in a scrolled window + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw sv + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + scrolledWindowSetShadowType sw ShadowIn + + let buf = IDEBuffer mbfn bn ind sv sw modTime + notebookInsertOrdered nb sw rbn + -- events + cid <- sv `afterFocusIn` + (\_ -> do runReaderT (makeActive buf) ideR; return True) + return (buf,[cid]) + addPaneAdmin buf (BufConnections cids [] []) panePath + lift $widgetShowAll (scrolledWindow buf) + lift $widgetGrabFocus (sourceView buf) + return buf + +checkModTime :: IDEBuffer -> IDEAction +checkModTime buf = do + panes <- readIDE panes + let name = paneName buf + case fileName buf of + Just fn -> do + exists <- lift $doesFileExist fn + if exists + then do + nmt <- lift $getModificationTime fn + case modTime buf of + Nothing -> throwIDE $"checkModTime: time not set " ++ show (fileName buf) + Just mt -> do + --message $"checkModTime " ++ name ++ " " ++ show mt ++ " " ++ show nmt + if nmt /= mt + then do + md <- lift $messageDialogNew + Nothing [] + MessageQuestion + ButtonsYesNo + ("File has changed on disk " ++ name ++ " Revert?") + resp <- lift $dialogRun md + case resp of + ResponseYes -> do + revert buf + lift $widgetHide md + ResponseNo -> do + let newPanes = Map.adjust (\b -> + if isIt BufferCasting b + then PaneC ((fromJust $ + downCast BufferCasting b) + {modTime = (Just nmt)}) + else b) name panes + modifyIDE_ (\ide -> return (ide{panes = newPanes})) + lift $widgetHide md + _ -> do return () + else return () + else return () + Nothing -> return () + +setModTime :: IDEBuffer -> IDEAction +setModTime buf = do + panes <- readIDE panes + let name = paneName buf + case fileName buf of + Nothing -> return () + Just fn -> do + nmt <- lift $getModificationTime fn + let newPanes = Map.adjust ( + \b -> if isIt BufferCasting b + then + PaneC ((fromJust $ downCast BufferCasting b) + {modTime = (Just nmt)}) + else b) name panes + modifyIDE_ (\ide -> return (ide{panes = newPanes})) + +fileRevert :: IDEAction +fileRevert = inBufContext' () $ \ _ _ currentBuffer _ -> do + revert currentBuffer + +revert :: IDEBuffer -> IDEAction +revert buf = do + useCandy <- getCandyState + ct <- readIDE candy + panes <- readIDE panes + let name = paneName buf + case fileName buf of + Nothing -> return () + Just fn -> do + mt <- lift $do + buffer' <- textViewGetBuffer (sourceView buf) + let buffer = castToSourceBuffer buffer' + fc <- readFile fn + mt <- getModificationTime fn + sourceBufferBeginNotUndoableAction buffer + textBufferSetText buffer fc + if useCandy + then transformToCandy ct (castToTextBuffer buffer) + else return () + sourceBufferEndNotUndoableAction buffer + textBufferSetModified buffer False + return mt + let newPanes = Map.adjust (\b -> if isIt BufferCasting b + then + PaneC ((fromJust $ downCast BufferCasting b) + {modTime = (Just mt)}) + else b) name panes + modifyIDE_ (\ide -> return (ide{panes = newPanes})) + +writeCursorPositionInStatusbar :: SourceView -> Statusbar -> IO() +writeCursorPositionInStatusbar sv sb = do + buf <- textViewGetBuffer sv + mark <- textBufferGetInsert buf + iter <- textBufferGetIterAtMark buf mark + line <- textIterGetLine iter + col <- textIterGetLineOffset iter + statusbarPop sb 1 + statusbarPush sb 1 $printf "Ln %4d, Col %3d" (line + 1) (col + 1) + return () + +writeOverwriteInStatusbar :: SourceView -> Statusbar -> IO() +writeOverwriteInStatusbar sv sb = do + modi <- textViewGetOverwrite sv + statusbarPop sb 1 + statusbarPush sb 1 $ if modi then "OVR" else "INS" + return () + + +showInfo :: SourceView -> IDERef -> IO () +showInfo sv ideR = do + buf <- textViewGetBuffer sv + (l,r) <- textBufferGetSelectionBounds buf + symbol <- textBufferGetText buf l r True + runReaderT (triggerEvent ideR (SelectInfo symbol)) ideR + return () + +markLabelAsChanged :: IDEAction +markLabelAsChanged = do + mbPath <- getActivePanePath + case mbPath of + Nothing -> return () + Just path -> do + nb <- getNotebook path + mbBS <- maybeActiveBuf + case mbBS of + Nothing -> return () + Just (buf,_) -> lift $do + gtkbuf <- textViewGetBuffer (sourceView buf) + modified <- textBufferGetModified gtkbuf + (Just text) <- notebookGetTabLabelText nb (scrolledWindow buf) + label <- labelNew Nothing + labelSetUseMarkup label True + labelSetMarkup label + (if modified + then "" ++ text ++ "" + else text) + notebookSetTabLabel nb (scrolledWindow buf) label + +inBufContext' :: alpha -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM alpha ) -> IDEM alpha +inBufContext' def f = do + mbBuf <- maybeActiveBuf + case mbBuf of + Nothing -> return def + Just (ideBuf,_) -> do + (pane,_) <- guiPropertiesFromName (paneName ideBuf) + nb <- getNotebook pane + mbI <- lift $notebookPageNum nb (scrolledWindow ideBuf) + case mbI of + Nothing -> lift $ do + sysMessage Normal "notebook page not found: unexpected" + return def + Just i -> do + gtkbuf <- lift $ textViewGetBuffer (sourceView ideBuf) + f nb gtkbuf ideBuf i + +inBufContext :: alpha -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IO alpha ) -> IDEM alpha +inBufContext def f = inBufContext' def (\ a b c d -> lift $ f a b c d) + +fileSave :: Bool -> IDEAction +fileSave query = inBufContext' () $ \ nb _ currentBuffer i -> do + ideR <- ask + window <- readIDE window + bufs <- readIDE panes + prefs <- readIDE prefs + paneMap <- readIDE paneMap + bs <- getCandyState + candy <- readIDE candy + (panePath,BufConnections s1 s2 s3) + <- guiPropertiesFromName (paneName currentBuffer) + mbnbufsPm <- do + let mbfn = fileName currentBuffer + mbpage <- lift $notebookGetNthPage nb i + case mbpage of + Nothing -> throwIDE "fileSave: Page not found" + Just page -> + if isJust mbfn && query == False + then do checkModTime currentBuffer + lift $fileSave' (forceLineEnds prefs) currentBuffer bs candy $fromJust mbfn + setModTime currentBuffer + return Nothing + else lift $do + dialog <- fileChooserDialogNew + (Just $ "Save File") + (Just window) + FileChooserActionSave + [("gtk-cancel" --buttons to display + ,ResponseCancel) --you can use stock buttons + ,("gtk-save" + , ResponseAccept)] + widgetShow dialog + response <- dialogRun dialog + mbFileName <- case response of + ResponseAccept -> fileChooserGetFilename dialog + ResponseCancel -> return Nothing + ResponseDeleteEvent-> return Nothing + _ -> return Nothing + widgetDestroy dialog + case mbFileName of + Nothing -> return Nothing + Just fn -> do + dfe <- doesFileExist fn + resp <- if dfe + then do md <- messageDialogNew (Just window) [] + MessageQuestion + ButtonsYesNo + "File already exist. Overwrite?" + resp <- dialogRun md + widgetHide md + return resp + else return ResponseYes + case resp of + ResponseYes -> do + fileSave' (forceLineEnds prefs) currentBuffer bs candy fn + modT <- getModificationTime fn + let bn = takeFileName fn + let bufs1 = Map.delete (paneName currentBuffer) bufs + let (ind,rbn) = figureOutPaneName bufs1 bn 0 + cfn <- canonicalizePath fn + let newBuffer = currentBuffer {fileName = Just cfn, + bufferName = bn, addedIndex = ind, modTime = Just modT} + let newBufs = Map.insert rbn (PaneC newBuffer) bufs1 + mapM_ signalDisconnect s1 + mapM_ signalDisconnect s2 + mapM_ signalDisconnect s3 + cid1 <- (sourceView currentBuffer) `afterFocusIn` + (\_ -> do runReaderT (makeActive newBuffer) ideR + return True) + let paneMap1 = Map.delete rbn paneMap + let newPaneMap = Map.insert rbn + (panePath,BufConnections [cid1] [] []) paneMap + label <- labelNew (Just rbn) + notebookSetTabLabel nb page label + return (Just (newBufs,newPaneMap)) + ResponseNo -> return Nothing + _ -> return Nothing + case mbnbufsPm of + Just (nbufs,pm) -> modifyIDE_ + (\ide -> return (ide{panes = nbufs, paneMap = pm})) + Nothing -> return () + where + fileSave' :: Bool -> IDEBuffer -> Bool -> CandyTable -> FilePath -> IO() + fileSave' forceLineEnds ideBuf bs ct fn = do + buf <- textViewGetBuffer $ sourceView ideBuf + text <- getCandylessText ct buf + let text' = unlines $map removeTrailingBlanks $lines text + if forceLineEnds + then do + file <- openBinaryFile fn WriteMode + hPutStr file text' + hClose file + else + writeFile fn text' + textBufferSetModified buf False + removeTrailingBlanks :: String -> String + removeTrailingBlanks = reverse . dropWhile (\c -> c == ' ') . reverse + +fileNew :: IDEAction +fileNew = do + prefs <- readIDE prefs + pp <- getActivePanePathOrStandard (sourcePanePath prefs) + newTextBuffer pp "Unnamed" Nothing + return () + +fileClose :: IDEM Bool +fileClose = inBufContext' True $ fileClose' + +fileClose' :: Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM Bool +fileClose' nb gtkbuf currentBuffer i = do + ideRef <- ask + window <- readIDE window + bufs <- readIDE panes + paneMap <- readIDE paneMap + cancel <- lift $ do + modified <- textBufferGetModified gtkbuf + if modified + then do + md <- messageDialogNew (Just window) [] + MessageQuestion + ButtonsNone + ("Save changes to document: " + ++ paneName currentBuffer + ++ "?") + dialogAddButton md "_Save" ResponseYes + dialogAddButton md "_Don't Save" ResponseNo + dialogAddButton md "_Cancel" ResponseCancel + resp <- dialogRun md + widgetDestroy md + case resp of + ResponseYes -> do + runReaderT (fileSave False) ideRef + return False + ResponseCancel -> return True + ResponseNo -> return False + _ -> return False + else return False + if cancel + then return False + else do + deactivatePane + lift $notebookRemovePage nb i + removePaneAdmin currentBuffer + return True + + +fileCloseAll :: IDEM Bool +fileCloseAll = do + bufs <- allBuffers + if null bufs + then return True + else do + makeActive (head bufs) + r <- fileClose + if r + then fileCloseAll + else return False + + +fileCloseAllButPackage :: IDEAction +fileCloseAllButPackage = do + mbActivePack <- readIDE activePack + bufs <- allBuffers + when (not (null bufs) && isJust mbActivePack) $ do + mapM_ (close' (fromJust mbActivePack)) bufs + where + close' activePack buf = do + (pane,_) <- guiPropertiesFromName (paneName buf) + nb <- getNotebook pane + mbI <- lift $notebookPageNum nb (scrolledWindow buf) + case mbI of + Nothing -> throwIDE "notebook page not found: unexpected" + Just i -> do + gtkbuf <- lift $ textViewGetBuffer (sourceView buf) + let dir = dropFileName $ cabalFile activePack + when (isJust (fileName buf)) $ do + modified <- lift $ textBufferGetModified gtkbuf + when (not modified && not (isSubPath dir (fromJust (fileName buf)))) + $ do fileClose' nb gtkbuf buf i; return () + +fileOpen :: IDEAction +fileOpen = do + window <- readIDE window + prefs <- readIDE prefs + mbFileName <- lift $ do + dialog <- fileChooserDialogNew + (Just $ "Open File") + (Just window) + FileChooserActionOpen + [("gtk-cancel" + ,ResponseCancel) + ,("gtk-open" + ,ResponseAccept)] + widgetShow dialog + response <- dialogRun dialog + case response of + ResponseAccept -> do + f <- fileChooserGetFilename dialog + widgetDestroy dialog + return f + ResponseCancel -> do + widgetDestroy dialog + return Nothing + ResponseDeleteEvent-> do + widgetDestroy dialog + return Nothing + _ -> return Nothing + case mbFileName of + Nothing -> return () + Just fp -> do + fpc <- lift $canonicalizePath fp + buffers <- allBuffers + let buf = filter (\b -> case fileName b of + Just fn -> equalFilePath fn fpc + Nothing -> False) buffers + case buf of + hdb:tl -> do + md <- lift $messageDialogNew + Nothing [] + MessageQuestion + ButtonsYesNo + ("Buffer already open. " ++ + "Make active instead of opening a second time?") + resp <- lift $dialogRun md + lift $ widgetDestroy md + case resp of + ResponseNo -> reallyOpen prefs fpc + _ -> makeActive hdb + [] -> reallyOpen prefs fpc + where + reallyOpen prefs fpc = do + pp <- getActivePanePathOrStandard (sourcePanePath prefs) + newTextBuffer pp (takeFileName fpc) (Just fpc) + return () + +editUndo :: IDEAction +editUndo = inBufContext () $ \_ gtkbuf _ _ -> + let sb = castToSourceBuffer gtkbuf in + do canUndo <- sourceBufferCanUndo sb + if canUndo + then sourceBufferUndo sb + else return () + +editRedo :: IDEAction +editRedo = inBufContext () $ \_ gtkbuf _ _ -> + let sb = castToSourceBuffer gtkbuf in + do canRedo <- sourceBufferCanUndo sb + if canRedo + then sourceBufferRedo sb + else return () + +editDelete :: IDEAction +editDelete = inBufContext () $ \_ gtkbuf _ _ -> do + textBufferDeleteSelection gtkbuf True True + return () + +editSelectAll :: IDEAction +editSelectAll = inBufContext () $ \_ gtkbuf _ _ -> do + start <- textBufferGetStartIter gtkbuf + end <- textBufferGetEndIter gtkbuf + textBufferSelectRange gtkbuf start end + +editCut :: IDEAction +#ifdef _Newgtk +editCut = inBufContext () $ \_ gtkbuf _ _ -> do + clip <- clipboardGet ClipClipboard + textBufferCutClipboard gtkbuf clip True +#else +editCut = return () +#endif + +editCopy :: IDEAction +#ifdef _Newgtk +editCopy = inBufContext () $ \_ gtkbuf _ _ -> do + clip <- clipboardGet ClipClipboard + textBufferCopyClipboard gtkbuf clip +#else +editCopy = return () +#endif + +editPaste :: IDEAction +#ifdef _Newgtk +editPaste = inBufContext () $ \_ gtkbuf _ _ -> do + mark <- textBufferGetInsert gtkbuf + iter <- textBufferGetIterAtMark gtkbuf mark + clip <- clipboardGet ClipClipboard + textBufferPasteClipboard gtkbuf clip iter True +#else +editPaste = return () +#endif + + +getStartAndEndLineOfSelection :: TextBuffer -> IO (Int,Int) +getStartAndEndLineOfSelection gtkbuf = do + startMark <- textBufferGetInsert gtkbuf + endMark <- textBufferGetSelectionBound gtkbuf + startIter <- textBufferGetIterAtMark gtkbuf startMark + endIter <- textBufferGetIterAtMark gtkbuf endMark + startLine <- textIterGetLine startIter + endLine <- textIterGetLine endIter + let (startLine',endLine',endIter') = if endLine >= startLine + then (startLine,endLine,endIter) + else (endLine,startLine,startIter) + b <- textIterStartsLine endIter' + let endLineReal = if b then endLine' - 1 else endLine' + return (startLine',endLineReal) + +doForSelectedLines :: [a] -> (TextBuffer -> TextIter -> Int -> IO a) -> IDEM [a] +doForSelectedLines d f = inBufContext' d $ \_ gtkbuf currentBuffer _ -> lift $do + (start,end) <- getStartAndEndLineOfSelection gtkbuf + iter <- textBufferGetStartIter gtkbuf + mapM (f gtkbuf iter) [start .. end] + +editComment :: IDEAction +editComment = do + doForSelectedLines [] $ \gtkbuf iter lineNr -> do + textIterSetLine iter lineNr + textBufferInsert gtkbuf iter "--" + return () + +editUncomment :: IDEAction +editUncomment = do + doForSelectedLines [] $ \gtkbuf iter lineNr -> do + textIterSetLine iter lineNr + iter2 <- textIterCopy iter + textIterForwardChars iter 2 + str <- textIterGetText iter iter2 + if str == "--" + then do textBufferDelete gtkbuf iter iter2 + else return () + return () + +editShiftLeft :: IDEAction +editShiftLeft = do + prefs <- readIDE prefs + let str = map (\_->' ') [1 .. (tabWidth prefs)] + b <- canShiftLeft str prefs + if b + then do + doForSelectedLines [] $ \gtkbuf iter lineNr -> do + textIterSetLine iter lineNr + iter2 <- textIterCopy iter + textIterForwardChars iter (tabWidth prefs) + textBufferDelete gtkbuf iter iter2 + return () + else return () + where + canShiftLeft str prefs = do + boolList <- doForSelectedLines [] $ \gtkbuf iter lineNr -> do + textIterSetLine iter lineNr + iter2 <- textIterCopy iter + textIterForwardChars iter (tabWidth prefs) + str1 <- textIterGetText iter iter2 + return (str1 == str) + return (foldl (&&) True boolList) + + +editShiftRight :: IDEAction +editShiftRight = do + prefs <- readIDE prefs + let str = map (\_->' ') [1 .. (tabWidth prefs)] + doForSelectedLines [] $ \gtkbuf iter lineNr -> do + textIterSetLine iter lineNr + textBufferInsert gtkbuf iter str + return () + +editToCandy :: IDEAction +editToCandy = do + ct <- readIDE candy + inBufContext () $ \_ gtkbuf _ _ -> do + transformToCandy ct gtkbuf + +editFromCandy :: IDEAction +editFromCandy = do + ct <- readIDE candy + inBufContext () $ \_ gtkbuf _ _ -> do + transformFromCandy ct gtkbuf + +editKeystrokeCandy :: Maybe Char -> IDEAction +editKeystrokeCandy c = do + ct <- readIDE candy + inBufContext () $ \_ gtkbuf _ _ -> do + keystrokeCandy ct c gtkbuf + +editCandy = do + ct <- readIDE candy + buffers <- allBuffers + gtkbufs <- lift $mapM (\ b -> textViewGetBuffer (sourceView b)) buffers + bs <- getCandyState + if bs + then lift $mapM_ (transformToCandy ct) gtkbufs + else lift $mapM_ (transformFromCandy ct) gtkbufs + + + + + + + + diff --git a/src/IDE/SpecialEditors.hs b/src/IDE/SpecialEditors.hs new file mode 100644 --- /dev/null +++ b/src/IDE/SpecialEditors.hs @@ -0,0 +1,290 @@ +-- +-- | Special Editors +-- + +module IDE.SpecialEditors ( + packageEditor +, testedWidthEditor +, compilerFlavorEditor +, versionRangeEditor +, versionEditor +, dependencyEditor +, dependenciesEditor +, filesEditor +, stringsEditor +, extensionsEditor +, panePathEditor +) where + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.ModelView as New +import Control.Monad.Reader +import Distribution.PackageDescription +import Distribution.Package +import Data.List(filter) +import Distribution.Compiler +import Distribution.Version +import Text.ParserCombinators.ReadP(readP_to_S) +import Language.Haskell.Extension + +import IDE.Core.State +import IDE.Framework.EditorBasics +import IDE.Framework.SimpleEditors +import IDE.Framework.CompositeEditors +import IDE.Framework.Parameters +import IDE.Utils.Default + +packageEditor :: Editor PackageIdentifier +packageEditor para = do + (wid,inj,ext,notif) <- pairEditor + (stringEditor, paraName <<<- ParaName "Name" $ emptyParams) + (versionEditor, paraName <<<- ParaName "Version" $ emptyParams) + (paraDirection <<<- ParaDirection Horizontal + $ paraShadow <<<- ParaShadow ShadowIn + $ para) + let pinj (PackageIdentifier n v) = inj (n,v) + let pext = do + mbp <- ext + case mbp of + Nothing -> return Nothing + Just (n,v) -> do + if null n + then return Nothing + else return (Just $PackageIdentifier n v) + return (wid,pinj,pext,notif) + +testedWidthEditor :: Editor [(CompilerFlavor, VersionRange)] +testedWidthEditor para = do + multisetEditor + (ColumnDescr False [("Compiler Flavor",\(cv,_) -> [New.cellText := show cv]) + ,("Version Range",\(_,vr) -> [New.cellText := showVersionRange vr])]) + (pairEditor + (compilerFlavorEditor, paraShadow <<<- (ParaShadow ShadowNone) $ emptyParams) + (versionRangeEditor, paraShadow <<<- (ParaShadow ShadowNone) $ emptyParams), + (paraDirection <<<- (ParaDirection Vertical) $ emptyParams)) + para + +compilerFlavorEditor :: Editor CompilerFlavor +compilerFlavorEditor para = do + (wid,inj,ext,notif) <- eitherOrEditor + (staticSelectionEditor flavors, paraName <<<- (ParaName "Select compiler") $ emptyParams) + (stringEditor, paraName <<<- (ParaName "Specify compiler") $ emptyParams) + "Other" + (paraName <<<- ParaName "Select" $ para) + let cfinj comp = case comp of + (OtherCompiler str) -> inj (Right "") + other -> inj (Left other) + let cfext = do + mbp <- ext + case mbp of + Nothing -> return Nothing + Just (Right s) -> return (Just $OtherCompiler s) + Just (Left other) -> return (Just other) + return (wid,cfinj,cfext,notif) + where + flavors = [GHC, NHC, Hugs, HBC, Helium, JHC] + +versionRangeEditor :: Editor VersionRange +versionRangeEditor para = do + (wid,inj,ext,notif) <- + maybeEditor + (eitherOrEditor + (pairEditor + (staticSelectionEditor v1, emptyParams) + (versionEditor, paraName <<<- ParaName "Enter Version" $ emptyParams), + (paraDirection <<<- ParaDirection Vertical) + $ paraName <<<- ParaName "Simple Version Range" + $ emptyParams) + (pairEditor + (staticSelectionEditor v2, emptyParams) + (pairEditor + (versionRangeEditor, paraShadow <<<- ParaShadow ShadowIn $ emptyParams) + (versionRangeEditor, paraShadow <<<- ParaShadow ShadowIn $ emptyParams), + paraDirection <<<- ParaDirection Vertical $ emptyParams), + paraDirection <<<- ParaDirection Vertical + $ paraName <<<- ParaName "Complex Version Range" + $ emptyParams) + "Complex",paraName <<<- ParaName "Simple" + $ emptyParams) False "Any Version" + (paraDirection <<<- ParaDirection Vertical $ para) + let vrinj AnyVersion = inj Nothing + vrinj (ThisVersion v) = inj (Just (Left (ThisVersionS,v))) + vrinj (LaterVersion v) = inj (Just (Left (LaterVersionS,v))) + vrinj (EarlierVersion v) = inj (Just (Left (EarlierVersionS,v))) + vrinj (UnionVersionRanges (ThisVersion v1) (LaterVersion v2)) | v1 == v2 + = inj (Just (Left (ThisOrLaterVersionS,v1))) + vrinj (UnionVersionRanges (LaterVersion v1) (ThisVersion v2)) | v1 == v2 + = inj (Just (Left (ThisOrLaterVersionS,v1))) + vrinj (UnionVersionRanges (ThisVersion v1) (EarlierVersion v2)) | v1 == v2 + = inj (Just (Left (ThisOrEarlierVersionS,v1))) + vrinj (UnionVersionRanges (EarlierVersion v1) (ThisVersion v2)) | v1 == v2 + = inj (Just (Left (ThisOrEarlierVersionS,v1))) + vrinj (UnionVersionRanges v1 v2)= inj (Just (Right (UnionVersionRangesS,(v1,v2)))) + vrinj (IntersectVersionRanges v1 v2) + = inj (Just (Right (IntersectVersionRangesS,(v1,v2)))) + let vrext = do mvr <- ext + case mvr of + Nothing -> return (Just AnyVersion) + Just Nothing -> return (Just AnyVersion) + Just (Just (Left (ThisVersionS,v))) -> return (Just (ThisVersion v)) + Just (Just (Left (LaterVersionS,v))) -> return (Just (LaterVersion v)) + Just (Just (Left (EarlierVersionS,v))) -> return (Just (EarlierVersion v)) + + Just (Just (Left (ThisOrLaterVersionS,v))) -> return (Just (orLaterVersion v)) + Just (Just (Left (ThisOrEarlierVersionS,v))) -> return (Just (orEarlierVersion v)) + Just (Just (Right (UnionVersionRangesS,(v1,v2)))) + -> return (Just (UnionVersionRanges v1 v2)) + Just (Just (Right (IntersectVersionRangesS,(v1,v2)))) + -> return (Just (IntersectVersionRanges v1 v2)) + return (wid,vrinj,vrext,notif) + where + v1 = [ThisVersionS,LaterVersionS,ThisOrLaterVersionS,EarlierVersionS,ThisOrEarlierVersionS] + v2 = [UnionVersionRangesS,IntersectVersionRangesS] + +data Version1 = ThisVersionS | LaterVersionS | ThisOrLaterVersionS | EarlierVersionS | ThisOrEarlierVersionS + deriving (Eq) +instance Show Version1 where + show ThisVersionS = "This Version" + show LaterVersionS = "Later Version" + show ThisOrLaterVersionS = "This or later Version" + show EarlierVersionS = "Earlier Version" + show ThisOrEarlierVersionS = "This or earlier Version" + +data Version2 = UnionVersionRangesS | IntersectVersionRangesS + deriving (Eq) +instance Show Version2 where + show UnionVersionRangesS = "Union Version Ranges" + show IntersectVersionRangesS = "Intersect Version Ranges" + +versionEditor :: Editor Version +versionEditor para = do + (wid,inj,ext,notiRef) <- stringEditor para + let pinj v = inj (showVersion v) + let pext = do + s <- ext + case s of + Nothing -> return Nothing + Just s -> do + let l = filter (\(h,t) -> null t) (readP_to_S parseVersion s) + if null l then + return Nothing + else return (Just (fst $head l)) + return (wid, pinj, pext, notiRef) + +dependencyEditor :: Editor Dependency +dependencyEditor para = do + (wid,inj,ext,notif) <- pairEditor + (stringEditor,paraName <<<- ParaName "Package Name" $ emptyParams) + (versionRangeEditor,paraName <<<- ParaName "Version" $ emptyParams) + (paraDirection <<<- ParaDirection Vertical $ para) + let pinj (Dependency s v) = inj (s,v) + let pext = do + mbp <- ext + case mbp of + Nothing -> return Nothing + Just ("",v) -> return Nothing + Just (s,v) -> return (Just $Dependency s v) + return (wid,pinj,pext,notif) + +dependenciesEditor :: Editor [Dependency] +dependenciesEditor p = + multisetEditor + (ColumnDescr True [("Package",\(Dependency str _) -> [New.cellText := str]) + ,("Version",\(Dependency _ vers) -> [New.cellText := showVersionRange vers])]) + (dependencyEditor,emptyParams) + (paraShadow <<<- ParaShadow ShadowIn $ p) + +filesEditor :: Maybe FilePath -> FileChooserAction -> String -> Editor [FilePath] +filesEditor fp act label p = + multisetEditor + (ColumnDescr False [("",(\row -> [New.cellText := row]))]) + (fileEditor fp act label, emptyParams) + (paraShadow <<<- ParaShadow ShadowIn $ p) + +stringsEditor :: Editor [String] +stringsEditor p = + multisetEditor + (ColumnDescr False [("",(\row -> [New.cellText := row]))]) + (stringEditor, emptyParams) + (paraShadow <<<- ParaShadow ShadowIn $ p) + +panePathEditor :: Editor StandardPath +panePathEditor = staticSelectionEditor [LeftTop,LeftBottom,RightTop,RightBottom] + +extensionsEditor :: Editor [Extension] +extensionsEditor = staticMultiselectionEditor extensionsL + +extensionsL :: [Extension] +extensionsL = [ + OverlappingInstances + , UndecidableInstances + , IncoherentInstances + , RecursiveDo + , ParallelListComp + , MultiParamTypeClasses + , NoMonomorphismRestriction + , FunctionalDependencies + , Rank2Types + , RankNTypes + , PolymorphicComponents + , ExistentialQuantification + , ScopedTypeVariables + , ImplicitParams + , FlexibleContexts + , FlexibleInstances + , EmptyDataDecls + , CPP + , BangPatterns + , TypeSynonymInstances + , TemplateHaskell + , ForeignFunctionInterface + , Arrows + , Generics + , NoImplicitPrelude + , NamedFieldPuns + , PatternGuards + , GeneralizedNewtypeDeriving + , ExtensibleRecords + , RestrictedTypeSynonyms + , HereDocuments] + +-- ------------------------------------------------------------ +-- * (Boring) default values +-- ------------------------------------------------------------ + +instance Default Version1 + where getDefault = ThisVersionS + +instance Default Version2 + where getDefault = UnionVersionRangesS + +instance Default Version + where getDefault = let version = (let l = (readP_to_S parseVersion) "0" + in if null l + then throwIDE "verion parser failed" + else fst $head l) + in version + +instance Default VersionRange + where getDefault = AnyVersion + +instance Default CompilerFlavor + where getDefault = GHC + +instance Default BuildInfo + where getDefault = emptyBuildInfo + +instance Default Library + where getDefault = Library [] getDefault + +instance Default Dependency + where getDefault = Dependency getDefault getDefault + +instance Default Executable + where getDefault = Executable getDefault getDefault getDefault + + + + + + diff --git a/src/IDE/ToolbarPane.hs b/src/IDE/ToolbarPane.hs new file mode 100644 --- /dev/null +++ b/src/IDE/ToolbarPane.hs @@ -0,0 +1,94 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.ToolbarPane +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | The pane of ide where modules are presented in tree form with their +-- packages and exports +-- +------------------------------------------------------------------------------- + +module IDE.ToolbarPane ( + getToolbar +) where + +import Graphics.UI.Gtk hiding (get) +import Data.Maybe +import Control.Monad.Reader + +import IDE.Core.State +import IDE.Framework.ViewFrame + +instance IDEObject IDEToolbar +instance Pane IDEToolbar + where + primPaneName _ = "Toolbar" + getTopWidget = castToWidget . toolbar + paneId b = "*Toolbar" + makeActive p = throwIDE "don't activate toolbar" + close pane = do + (panePath,_) <- guiPropertiesFromName (paneName pane) + nb <- getNotebook panePath + mbI <- lift $notebookPageNum nb (getTopWidget pane) + case mbI of + Nothing -> lift $ do + sysMessage Normal "notebook page not found: unexpected" + return () + Just i -> do + deactivatePaneIfActive pane + lift $notebookRemovePage nb i + removePaneAdmin pane + + +instance RecoverablePane IDEToolbar ToolbarState where + saveState p = do + mbToolbar <- getPane ToolbarCasting + case mbToolbar of + Nothing -> return Nothing + Just p -> lift $ do + return (Just (StateC ToolbarState)) + recoverState pp ToolbarState = do + nb <- getNotebook pp + initToolbar pp nb + +getToolbar :: IDEM IDEToolbar +getToolbar = do + mbToolbar <- getPane ToolbarCasting + case mbToolbar of + Nothing -> do + prefs <- readIDE prefs + layout <- readIDE layout + let pp = getStandardPanePath (controlPanePath prefs) layout + nb <- getNotebook pp + initToolbar pp nb + mbToolbar <- getPane ToolbarCasting + case mbToolbar of + Nothing -> throwIDE "Can't init control pane" + Just m -> return m + Just m -> return m + +initToolbar :: PanePath -> Notebook -> IDEAction +initToolbar panePath nb = do + ideR <- ask + currentInfo <- readIDE currentInfo + res <- triggerEvent ideR (GetToolbar []) + let (tb1,tb2) = case res of + GetToolbar (_:t1:t2:_) -> (t1,t2) + _ -> throwIDE "Failed to build toolbar" + (buf,cids) <- lift $ do + vb <- vBoxNew False 0 + boxPackStart vb tb1 PackNatural 0 + boxPackStart vb tb2 PackNatural 0 + let toolbar' = IDEToolbar vb + notebookInsertOrdered nb vb (paneName toolbar') + widgetShowAll vb + return (toolbar',[]) + addPaneAdmin buf (BufConnections [] [] []) panePath + lift $widgetGrabFocus (toolbar buf) + diff --git a/src/IDE/Utils/DeepSeq.hs b/src/IDE/Utils/DeepSeq.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Utils/DeepSeq.hs @@ -0,0 +1,60 @@ +module IDE.Utils.DeepSeq where + +class DeepSeq a where + deepSeq :: a -> b -> b + +infixr 0 `deepSeq`, $!! + +($!!) :: (DeepSeq a) => (a -> b) -> a -> b +f $!! x = x `deepSeq` f x + +instance DeepSeq () where deepSeq = seq + +instance DeepSeq Bool where deepSeq = seq +instance DeepSeq Char where deepSeq = seq + +instance (DeepSeq a) => DeepSeq (Maybe a) where + deepSeq Nothing y = y + deepSeq (Just x) y = deepSeq x y + +instance (DeepSeq a, DeepSeq b) => DeepSeq (Either a b) where + deepSeq (Left a) y = deepSeq a y + deepSeq (Right b) y = deepSeq b y + +instance DeepSeq Ordering where deepSeq = seq + +instance DeepSeq Int where deepSeq = seq +instance DeepSeq Integer where deepSeq = seq +instance DeepSeq Float where deepSeq = seq +instance DeepSeq Double where deepSeq = seq + +instance DeepSeq (a -> b) where deepSeq = seq + +instance DeepSeq (IO a) where deepSeq = seq + +instance (DeepSeq a) => DeepSeq [a] where + deepSeq [] y = y + deepSeq (x:xs) y = deepSeq x $ deepSeq xs y + +instance (DeepSeq a,DeepSeq b) => DeepSeq (a,b) where + deepSeq (a,b) y = deepSeq a $ deepSeq b y + +instance (DeepSeq a,DeepSeq b,DeepSeq c) => DeepSeq (a,b,c) where + deepSeq (a,b,c) y = deepSeq a $ deepSeq b $ deepSeq c y + +instance (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d) => DeepSeq (a,b,c,d) where + deepSeq (a,b,c,d) y = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d y + +instance (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d,DeepSeq e) => DeepSeq (a,b,c,d,e) where + deepSeq (a,b,c,d,e) y = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d $ deepSeq e y + +instance (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d,DeepSeq e,DeepSeq f) => DeepSeq (a,b,c,d,e,f) where + deepSeq (a,b,c,d,e,f) y = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d $ deepSeq e $ deepSeq f y + +instance (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d,DeepSeq e,DeepSeq f,DeepSeq g) => DeepSeq (a,b,c,d,e,f,g) where + deepSeq (a,b,c,d,e,f,g) y = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d $ deepSeq e $ deepSeq f $ deepSeq g y + + + + + diff --git a/src/IDE/Utils/Default.hs b/src/IDE/Utils/Default.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Utils/Default.hs @@ -0,0 +1,40 @@ + +----------------------------------------------------------------------------- +-- +-- Module : IDE.Utils.Default +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | Module for default values of a data type +-- +------------------------------------------------------------------------------ + +module IDE.Utils.Default ( + Default(..) +) where + +-- +-- | A class for providing default values for certain types of editors +-- +class Default alpha where + getDefault :: alpha + +instance Default Int where + getDefault = 1 + +instance Default alpha => Default (Either alpha beta) where + getDefault = Left(getDefault) + +instance (Default alpha, Default beta) => Default (alpha, beta) where + getDefault = (getDefault,getDefault) + +instance Default [alpha] where + getDefault = [] + +instance Default (Maybe alpha) where + getDefault = Nothing + diff --git a/src/IDE/Utils/File.hs b/src/IDE/Utils/File.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Utils/File.hs @@ -0,0 +1,252 @@ +module IDE.Utils.File ( + allModules +, allHiFiles +, allHaskellSourceFiles +, cabalFileName +, allCabalFiles +, getConfigFilePathForLoad +, hasConfigDir +, getConfigFilePathForSave +, getCollectorPath +, getSysLibDir +, moduleNameFromFilePath +, findKnownPackages +, isSubPath +, findSourceFile + +) where + +import System.FilePath +import System.Directory +import System.IO +import Data.Char +import System.Process +import Text.ParserCombinators.Parsec hiding (Parser) +import qualified Text.ParserCombinators.Parsec.Token as P +import Text.ParserCombinators.Parsec.Language(haskell,haskellDef) +import Data.Maybe (catMaybes) +import Distribution.Simple.PreProcess.Unlit +import Control.Monad +import qualified Data.List as List +import qualified Data.Set as Set +import Data.Set (Set) +import Data.List(isSuffixOf, isPrefixOf) + +import Paths_leksah +import IDE.Core.State + +-- | Returns True if the second path is a location which starts with the first path +isSubPath :: FilePath -> FilePath -> Bool +isSubPath fp1 fp2 = + let fpn1 = splitPath $ normalise fp1 + fpn2 = splitPath $ normalise fp2 + res = isPrefixOf fpn1 fpn2 + in res + +findSourceFile :: [FilePath] + -> [String] + -> ModuleIdentifier + -> IO (Maybe FilePath) +findSourceFile directories exts modId = + let modulePath = dots_to_slashes modId + allPathes = map (\ d -> d modulePath) directories + allPossibles = concatMap (\ p -> map (addExtension p) exts) + allPathes + in find' allPossibles + +find' :: [FilePath] -> IO (Maybe FilePath) +find' [] = return Nothing +find' (h:t) = do + exists <- doesFileExist h + if exists + then return (Just h) + else find' t + +dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) + +-- The directory where config files reside +-- +getConfigDir :: IO FilePath +getConfigDir = do + d <- getHomeDirectory + let filePath = d ".leksah" + exists <- doesDirectoryExist filePath + if exists + then return filePath + else do + createDirectory filePath + return filePath + +hasConfigDir :: IO Bool +hasConfigDir = do + d <- getHomeDirectory + let filePath = d ".leksah" + doesDirectoryExist filePath + + +getConfigFilePathForLoad :: String -> IO FilePath +getConfigFilePathForLoad fn = do + cd <- getConfigDir + ex <- doesFileExist (cd fn) + if ex + then return (cd fn) + else do + dd <- getDataDir + ex <- doesFileExist (dd "data" fn) + if ex + then return (dd "data" fn) + else throwIDE $"Config file not found: " ++ fn + +getConfigFilePathForSave :: String -> IO FilePath +getConfigFilePathForSave fn = do + cd <- getConfigDir + return (cd fn) + +allModules :: FilePath -> IO [String] +allModules filePath = do + exists <- doesDirectoryExist filePath + if exists + then do + filesAndDirs <- getDirectoryContents filePath + let filesAndDirs' = map (\s -> combine filePath s) + $filter (\s -> s /= "." && s /= ".." && s /= "_darcs" && s /= "dist" + && s /= "Setup.lhs") filesAndDirs + dirs <- filterM (\f -> doesDirectoryExist f) filesAndDirs' + files <- filterM (\f -> doesFileExist f) filesAndDirs' + let hsFiles = filter (\f -> let ext = takeExtension f in + ext == ".hs" || ext == ".lhs") files + mbModuleNames <- mapM moduleNameFromFilePath hsFiles + otherModules <- mapM allModules dirs + return (catMaybes mbModuleNames ++ concat otherModules) + else return [] + +allHiFiles :: FilePath -> IO [FilePath] +allHiFiles = allFilesWithExtensions [".hi"] True + +allCabalFiles :: FilePath -> IO [FilePath] +allCabalFiles = allFilesWithExtensions [".cabal"] False + +allHaskellSourceFiles :: FilePath -> IO [FilePath] +allHaskellSourceFiles = allFilesWithExtensions [".hs",".lhs"] True + +allFilesWithExtensions :: [String] -> Bool -> FilePath -> IO [FilePath] +allFilesWithExtensions extensions recurseFurther filePath = do + exists <- doesDirectoryExist filePath + if exists + then do + filesAndDirs <- getDirectoryContents filePath + let filesAndDirs' = map (\s -> combine filePath s) + $filter (\s -> s /= "." && s /= ".." && s /= "_darcs") filesAndDirs + dirs <- filterM (\f -> doesDirectoryExist f) filesAndDirs' + files <- filterM (\f -> doesFileExist f) filesAndDirs' + let choosenFiles = filter (\f -> let ext = takeExtension f in + List.elem ext extensions) files + otherFiles <- + if recurseFurther || (not recurseFurther && null choosenFiles) + then mapM (allFilesWithExtensions extensions recurseFurther) dirs + else return [] + return (choosenFiles ++ concat otherFiles) + else return [] + + + +moduleNameFromFilePath :: FilePath -> IO (Maybe String) +moduleNameFromFilePath fp = do + exists <- doesFileExist fp + if exists + then do + str <- readFile fp + let str' = if takeExtension fp == ".lhs" + then unlit fp str + else str + let parseRes = parse moduleNameParser fp str' + case parseRes of + Left err -> do + sysMessage Normal $show err + return Nothing + Right str -> do + return (Just str) + else return Nothing + +lexer = haskell +lexeme = P.lexeme lexer +whiteSpace = P.whiteSpace lexer +hexadecimal = P.hexadecimal lexer +symbol = P.symbol lexer + +moduleNameParser :: CharParser () String +moduleNameParser = do + whiteSpace + many skipPreproc + whiteSpace + symbol "module" + str <- lexeme mident +-- skipMany anyChar +-- eof + return str + "module identifier" + +skipPreproc :: CharParser () () +skipPreproc = do + try (do + whiteSpace + char '#' + many (noneOf "\n") + return ()) + "preproc" + +mident + = do{ c <- P.identStart haskellDef + ; cs <- many (alphaNum <|> oneOf "_'.") + ; return (c:cs) + } + "midentifier" + +findKnownPackages :: FilePath -> IO (Set String) +findKnownPackages filePath = do + paths <- getDirectoryContents filePath + let nameList = map dropExtension $filter (\s -> ".pack" `isSuffixOf` s) paths + return (Set.fromList nameList) + +cabalFileName :: FilePath -> IO (Maybe String) +cabalFileName filePath = do + exists <- doesDirectoryExist filePath + if exists + then do + filesAndDirs <- getDirectoryContents filePath + files <- filterM (\f -> doesFileExist f) filesAndDirs + let cabalFiles = filter (\f -> let ext = takeExtension f in ext == ".cabal") files + if null cabalFiles + then return Nothing + else if length cabalFiles == 1 + then return (Just $head cabalFiles) + else do + sysMessage Normal "Multiple cabal files" + return Nothing + else return Nothing + +getCollectorPath :: String -> IO FilePath +getCollectorPath version = do + configDir <- getConfigDir + let filePath = configDir "ghc-" ++ version + exists <- doesDirectoryExist filePath + if exists + then return filePath + else do + createDirectory filePath + return filePath + +getSysLibDir :: IO FilePath +getSysLibDir = do + (_, out, _, pid) <- runInteractiveProcess "ghc" ["--print-libdir"] Nothing Nothing + libDir <- hGetLine out + let libDir2 = if ord (last libDir) == 13 + then take (length libDir - 1) libDir + else libDir + waitForProcess pid + return (normalise libDir2) + + + + + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,4 @@ +import IDE.Leksah + +main = runMain +