packages feed

leksah (empty) → 0.1

raw patch · 72 files changed

+13039/−0 lines, 72 filesdep +Cabaldep +basedep +binarybuild-type:Customsetup-changedbinary-added

Dependencies added: Cabal, base, binary, bytestring, containers, directory, filepath, ghc, glib, gtk, mtl, old-time, parsec, pretty, process, sourceview

Files

+ LICENSE view
@@ -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.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    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.++  <signature of Ty Coon>, 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.
+ Readme view
@@ -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 <jnf@arcor.de>++++++
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+
+ data/Current.session view
@@ -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
+ data/Default.candy view
@@ -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++
+ data/Default.keymap view
@@ -0,0 +1,77 @@+--Default Keymap file for Genuine Haskell Face+--Allowed Modifiers are <shift>	<ctrl> <alt> <apple> <compose>+--<apple> is the Windows key on PC keyboards+--<compose> is often labelled Alt Gr.+++--File+<ctrl>n                 ->          FileNew         "Opens a new empty buffer"++<ctrl>o                 ->          FileOpen        "Opens an existing file"+--<ctrl>x/<ctrl>f         ->          FileOpen        "Opens an existing file"++<ctrl>s                 ->          FileSave        "Saves the current buffer"+--<ctrl>x/<ctrl>s         ->          FileSave        "Saves the current buffer"++<ctrl><shift>s          ->          FileSaveAs      "Saves the current buffer as a new file"+--<ctrl>x/<ctrl>w         ->          FileSaveAs      "Saves the current buffer as a new file"++<ctrl>w                 ->          FileClose       "Closes the current buffer"+--<ctrl>x/k               ->          FileClose       "Closes the current buffer"++<alt>F4                 ->          Quit            "Quits this program"+--<ctrl>x/<ctrl>c         ->          Quit            "Quits this program"++--Edit+<ctrl>z                 ->          EditUndo        "Undos the last user action"+--<ctrl>x/u               ->          EditUndo        "Undos the last user action"++<shift><ctrl>y          ->          EditRedo        "Redos the last user action"+--<ctrl>x/r               ->          EditRedo        "Redos the last user action"++--Just "<ctrl>X"     ->          EditCut+--Just "<ctrl>C"     ->          EditCopy+--Just "<ctrl>V"     ->          EditPaste+                        ->          EditDelete+<ctrl>a                 ->          EditSelectAll   "Select the whole text in the current buffer"++F3                      ->          EditFind            "Quits this program"+<ctrl>f                 ->          EditFindNext        "Search for a text string"++<ctrl><shift>f          ->          EditFindPrevious+                                                    "Find the previous occurence of the text string"+<ctrl>r                 ->          EditReplace++<ctrl>l                 ->          EditGotoLine    "Go to line with a known index"++<ctrl><alt>Right        ->          EditComment     "Add a line style comment to the selected lies"+<ctrl><alt>Left         ->          EditUncomment   "Remove a line style comment"+<alt>Right              ->          EditShiftRight  "Shift right"+<alt>Left               ->          EditShiftLeft   "Shift Left"++--View+<alt><shift>Left           ->          ViewMoveLeft    "Move the current pane left"+<alt><shift>Right          ->          ViewMoveRight   "Move the current pane right"+<alt><shift>Up             ->          ViewMoveUp      "Move the current pane up"+<alt><shift>Down           ->          ViewMoveDown    "Move the current pane down"++<ctrl>2                 ->          ViewSplitHorizontal+                                                    "Split the current pane in horizontal direction"+<ctrl>3                 ->          ViewSplitVertical+                                                    "Split the current pane in vertical direction"+<ctrl>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++<ctrl>b                 ->          BuildPackage++<ctrl><alt>r            ->          RunPackage++<ctrl>j                 ->          NextError+<ctrl><shift>j          ->          PreviousError
+ data/Default.menu view
@@ -0,0 +1,123 @@+   <ui>+    <menubar>+      <menu name="_File" action="File">+       <menuitem name="_New" action="FileNew" />+       <menuitem name="_Open" action="FileOpen" />+       <menuitem name="_Revert" action="FileRevert" />+       <separator/>+       <menuitem name="_Save" action="FileSave" />+       <menuitem name="Save_As" action="FileSaveAs" />+       <separator/>+       <menuitem name="_Close" action="FileClose" />+       <menuitem name="Close All" action="FileCloseAll" />+       <menuitem name="Close All but Package" action="FileCloseAllButPackage" />+      <menuitem name="_Quit" action="Quit" />+     </menu>+     <menu name="_Edit" action="Edit">+       <menuitem name="_Undo" action="EditUndo" />+       <menuitem name="_Redo" action="EditRedo" />+       <separator/>+       <menuitem name="Cu_t" action="EditCut" />+       <menuitem name="_Copy" action="EditCopy" />+       <menuitem name="_Paste" action="EditPaste" />+       <menuitem name="_Delete" action="EditDelete" />+       <separator/>+       <menuitem name="Select _All" action="EditSelectAll" />+       <separator/>+       <menuitem name="_Find" action="EditFind" />+       <menuitem name="Find_Next" action="EditFindNext" />+       <menuitem name="Find_Previous" action="EditFindPrevious" />+       <menuitem name="_Goto Line" action="EditGotoLine" />+       <separator/>+       <menuitem name="Replace" action="EditReplace" />+       <separator/>+       <menuitem name="Comment" action="EditComment" />+       <menuitem name="Uncomment" action="EditUncomment" />+       <menuitem name="Shift Left" action="EditShiftLeft" />+       <menuitem name="Shift Right" action="EditShiftRight" />+       <separator/>+       <menuitem name="Source Candy" action="EditCandy" />+     </menu>+    <menu name="_Package" action="Package">+       <menuitem name="_New Package" action="NewPackage" />+       <menuitem name="_Open Package" action="OpenPackage" />+       <menuitem name="_Edit Package" action="EditPackage" />+       <menuitem name="_Close Package" action="ClosePackage" />+       <separator/>+       <menuitem name="Edit _Flags" action="PackageFlags" />+       <menuitem name="_Configure Package" action="ConfigPackage" />+       <menuitem name="_Build Package" action="BuildPackage" />+       <menuitem name="_Run" action="RunPackage" />+       <menuitem name="_Next Error" action="NextError" />+       <menuitem name="_Previous Error" action="PreviousError" />+       <separator/>+       <menuitem name="Clea_n Package" action="CleanPackage" />+       <menuitem name="C_opy Package" action="CopyPackage" />+       <menuitem name="_Install Package" action="InstallPackage" />+       <menuitem name="Re_gister Package" action="RegisterPackage" />+       <menuitem name="_Unregister Package" action="UnregisterPackage" />+       <menuitem name="Test Package" action="TestPackage" />+       <menuitem name="SDist Package" action="SdistPackage" />+       <separator/>+       <menuitem name="_Build Documentation" action="DocPackage" />+       <menuitem name="Open Documentation" action="OpenDocPackage" />+     </menu>+    <menu name="_View" action="View">+       <menuitem name="Move _Left" action="ViewMoveLeft" />+       <menuitem name="Move _Right" action="ViewMoveRight" />+       <menuitem name="Move _Up" action="ViewMoveUp" />+       <menuitem name="Move _Down" action="ViewMoveDown" />+       <separator/>+       <menuitem name="Split H_orizontal" action="ViewSplitHorizontal" />+       <menuitem name="Split V_ertical" action="ViewSplitVertical" />+       <menuitem name="_Collapse" action="ViewCollapse" />+       <separator/>+       <menuitem name="Tabs _Left" action="ViewTabsLeft" />+       <menuitem name="Tabs _Right" action="ViewTabsRight" />+       <menuitem name="Tabs _Up" action="ViewTabsUp" />+       <menuitem name="Tabs _Down" action="ViewTabsDown" />+       <menuitem name="Switch Tabs" action="ViewSwitchTabs" />+       <separator/>+       <menuitem name="Close Pane" action="ViewClosePane" />+       <separator/>+       <menuitem name="Clear Log" action="ClearLog" />+       <menuitem name="Show Toolbar" action="ShowToolbar" />+       <menuitem name="Show Find" action="ShowFind" />+       <menuitem name="Show Replace" action="ShowReplace" />+       <menuitem name="Show _Modules" action="ShowModules" />+     </menu>+    <menu name="_Help" action="Help">+       <menuitem name="Edit Preferences" action="PrefsEdit" />+       <menuitem name="_About" action="HelpAbout" />+       <menuitem name="Debug" action="HelpDebug" />+     </menu>+   </menubar>+    <toolbar name="toolbar1">+     <placeholder name="FileToolItems">+       <separator/>+       <toolitem name="New" action="FileNew"/>+       <toolitem name="Open" action="FileOpen"/>+       <toolitem name="Save" action="FileSave"/>+       <toolitem name="Close" action="ViewClosePane"/>+       <separator/>+     </placeholder>+     <placeholder name="FileEditItems">+       <separator/>+       <toolitem name="Undo" action="EditUndo"/>+       <toolitem name="Redo" action="EditRedo"/>+       <separator/>+       <toolitem name="Find" action="EditFind"/>+     </placeholder>+   </toolbar>+   <toolbar name="toolbar2">+     <placeholder name="BuildToolItems">+       <separator/>+       <toolitem name="Configure" action="ConfigPackage"/>+       <toolitem name="Build" action="BuildPackage"/>+       <toolitem name="Run" action="RunPackage"/>+       <toolitem name="Next Error" action="NextError"/>+       <toolitem name="Previous Error" action="PreviousError"/>+       <separator/>+     </placeholder>+   </toolbar>+ </ui>
+ data/Default.prefs view
@@ -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]
+ data/Emacs.keymap view
@@ -0,0 +1,66 @@+--Default Keymap file for Genuine Haskell Face+--Allowed Modifiers are <shift>	<ctrl> <alt>	<apple> <compose>+--Apple is the Windows key on PC keyboards+--Compose is often labelled Alt Gr.+++--File+<ctrl>n                 ->          FileNew         "Opens a new empty buffer"+<ctrl>x/<ctrl>f         ->          FileOpen        "Opens an existing file"+<ctrl>x/<ctrl>s         ->          FileSave        "Saves the current buffer"+<ctrl>x/<ctrl>w         ->          FileSaveAs      "Saves the current buffer as a new file"+<ctrl>x/k               ->          FileClose       "Closes the current buffer"+<ctrl>x/<ctrl>c         ->          Quit            "Quits kthis program"+++--Edit+<ctrl>x/u               ->          EditUndo        "Undos the last user action"+--<ctrl><shift>_          ->          EditUndo        "Undos the last user action"+<ctrl>x/r               ->          EditRedo        "Redos the last user action"+<ctrl>w                 ->          EditCut+<alt>w                  ->          EditCopy+<ctrl>y                 ->          EditPaste+                        ->          EditDelete+<ctrl>a                 ->          EditSelectAll   "Select the whole text in the current buffer"++<ctrl>s                 ->          EditFind        "Search for a text string"+F3                      ->          EditFindNext    "Find the next occurence of the text string"+--<ctrl>k                 ->          EditFind        "Search for a text string"++<ctrl>r                 ->          EditFindPrevious+                                                    "Find the previous occurence of the text string"+<alt>r                  ->          EditReplace++<ctrl>L                 ->          EditGotoLine    "Go to line with a known index"++<ctrl>7                 ->          EditComment     "Add a line style comment to the selected lies"+<ctrl><shift>7          ->          EditUncomment   "Remove a line style comment"+<alt>Right              ->          EditShiftRight  "Shift right"+<alt>Left               ->          EditShiftLeft   "Shift Left"++--View+<alt><shift>Left        ->          ViewMoveLeft        "Move the current pane left"+<alt><shift>Right       ->          ViewMoveRight   "Move the current pane right"+<alt><shift>Up          ->          ViewMoveUp      "Move the current pane up"+<alt><shift>Down        ->          ViewMoveDown    "Move the current pane down"++<Ctrl>2                 ->          ViewSplitHorizontal+                                                    "Split the current pane in horizontal direction"+<Ctrl>3                 ->          ViewSplitVertical+                                                    "Split the current pane in vertical direction"+<Ctrl>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++<ctrl>b                 ->          BuildPackage++<ctrl><shift>r          ->          RunPackage++<ctrl>j                 ->          NextError+<ctrl><shift>j          ->          PreviousError
+ data/ide_class.png view

binary file changed (absent → 2294 bytes)

+ data/ide_configure.png view

binary file changed (absent → 1353 bytes)

+ data/ide_data.png view

binary file changed (absent → 2112 bytes)

+ data/ide_error_next.png view

binary file changed (absent → 766 bytes)

+ data/ide_error_prev.png view

binary file changed (absent → 756 bytes)

+ data/ide_field.png view

binary file changed (absent → 1803 bytes)

+ data/ide_function.png view

binary file changed (absent → 1816 bytes)

+ data/ide_instance.png view

binary file changed (absent → 1500 bytes)

+ data/ide_konstructor.png view

binary file changed (absent → 2219 bytes)

+ data/ide_make.png view

binary file changed (absent → 425 bytes)

+ data/ide_method.png view

binary file changed (absent → 2333 bytes)

+ data/ide_newtype.png view

binary file changed (absent → 2165 bytes)

+ data/ide_no_source.png view

binary file changed (absent → 154 bytes)

+ data/ide_other.png view

binary file changed (absent → 1210 bytes)

+ data/ide_rule.png view

binary file changed (absent → 2248 bytes)

+ data/ide_run.png view

binary file changed (absent → 1553 bytes)

+ data/ide_slot.png view

binary file changed (absent → 2488 bytes)

+ data/ide_source.png view

binary file changed (absent → 353 bytes)

+ data/ide_type.png view

binary file changed (absent → 1683 bytes)

+ data/leksah.png view

binary file changed (absent → 9415 bytes)

+ doc/Todo.txt view
@@ -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)+      -   <ctrl><alt>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+++
+ doc/leksah_manual.pdf view

binary file changed (absent → 535399 bytes)

+ leksah.cabal view
@@ -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:
+ src/IDE/BuildInfoEditor.hs view
@@ -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)++++++++
+ src/IDE/CallersPane.hs view
@@ -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 <jnf at arcor.de>+-- 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"+
+ src/IDE/Core/Exception.hs view
@@ -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 <jnf at arcor.de>+-- 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<size> 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+  )
+ src/IDE/Core/Panes.hs view
@@ -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 <jnf at arcor.de>+-- 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)+++++
+ src/IDE/Core/State.hs view
@@ -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 <jnf at arcor.de>+-- 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+
+ src/IDE/Core/State.hs-boot view
@@ -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 ()++
+ src/IDE/Core/Types.hs view
@@ -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 <jnf at arcor.de>+-- 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    =   "<shift>"+          show Control  =   "<ctrl>"+          show Alt      =   "<alt>"+          show Apple    =   "<apple>"+          show Compose  =   "<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)+++++
+ src/IDE/DescriptionPP.hs view
@@ -0,0 +1,95 @@+-----------------------------------------------------------------------------+--+-- Module      :  IDE.DescriptionPP+-- Copyright   :  (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License     :  GNU-GPL+--+-- Maintainer  :  Juergen Nicklisch-Franken <jnf at arcor.de>+-- 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)++
+ src/IDE/FindPane.hs view
@@ -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 <jnf at arcor.de>+-- 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++++
+ src/IDE/Framework/CompositeEditors.hs view
@@ -0,0 +1,402 @@+-----------------------------------------------------------------------------+--+-- Module      :  IDE.Framework.CompositeEditors+-- Copyright   :  (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License     :  GNU-GPL+--+-- Maintainer  :  Juergen Nicklisch-Franken <jnf at arcor.de>+-- 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 ()+
+ src/IDE/Framework/EditorBasics.hs view
@@ -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 <jnf at arcor.de>+-- 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)++
+ src/IDE/Framework/MakeEditor.hs view
@@ -0,0 +1,265 @@+-----------------------------------------------------------------------------+--+-- Module      :  IDE.Framework.MakeEditor+-- Copyright   :  (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License     :  GNU-GPL+--+-- Maintainer  :  Juergen Nicklisch-Franken <jnf at arcor.de>+-- 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++++
+ src/IDE/Framework/Parameters.hs view
@@ -0,0 +1,148 @@+-----------------------------------------------------------------------------+--+-- Module      :  IDE.Framework.Parameters+-- Copyright   :  (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License     :  GNU-GPL+--+-- Maintainer  :  Juergen Nicklisch-Franken <jnf at arcor.de>+-- 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]
+ src/IDE/Framework/SimpleEditors.hs view
@@ -0,0 +1,561 @@+-----------------------------------------------------------------------------+--+-- Module      :  IDE.Framework.SimpleEditors+-- Copyright   :  (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License     :  GNU-GPL+--+-- Maintainer  :  Juergen Nicklisch-Franken <jnf at arcor.de>+-- 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)
+ src/IDE/Framework/ViewFrame.hs view
@@ -0,0 +1,697 @@+-----------------------------------------------------------------------------+--+-- Module      :  IDE.Framework.ViewFrame+-- Copyright   :  (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License     :  GNU-GPL+--+-- Maintainer  :  Juergen Nicklisch-Franken <jnf at arcor.de>+-- 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++
+ src/IDE/InfoPane.hs view
@@ -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 <jnf at arcor.de>+-- 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+
+ src/IDE/Keymap.hs view
@@ -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 "<shift>"+    return Shift+    <|> do+    try $symbol2 "<control>"+    return Control+    <|> do+    try $symbol2 "<ctrl>"+    return Control+    <|> do+    try $symbol2 "<alt>"+    return Alt+    <|> do+    try $symbol2 "<apple>"+    return Apple+    <|> do+    try $symbol2 "<compose>"+    return Compose+    <?>"modparser"+
+ src/IDE/Leksah.hs view
@@ -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 <jnf at arcor.de>+-- 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
+ src/IDE/Log.hs view
@@ -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 <jnf at arcor.de>+-- 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}))+
+ src/IDE/Menu.hs view
@@ -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 <jnf at arcor.de>+-- 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 "<control>X"--} False+    ,AD "EditCopy" "_Copy"  Nothing  Nothing{--Just "gtk-copy"--}+        editCopy [] {--Just "<control>C"--} False+    ,AD "EditPaste" "_Paste" Nothing Nothing{--Just "gtk-paste"--}+        editPaste [] {--Just "<control>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 "<Ctrl>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+++++
+ src/IDE/Metainfo/Info.hs view
@@ -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 <jnf at arcor.de>+-- 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)+
+ src/IDE/Metainfo/InterfaceCollector.hs view
@@ -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 <jnf at arcor.de>+-- 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')++
+ src/IDE/Metainfo/SourceCollector.hs view
@@ -0,0 +1,580 @@+-----------------------------------------------------------------------------+--+-- Module      :  IDE.Metainfo.SourceCollector+-- Copyright   :  (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License     :  GNU-GPL+--+-- Maintainer  :  Juergen Nicklisch-Franken <jnf at arcor.de>+-- 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.+      }}++
+ src/IDE/ModulesPane.hs view
@@ -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 <jnf at arcor.de>+-- 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+++++++
+ src/IDE/Package.hs view
@@ -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 <jnf at arcor.de>+-- 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
+ src/IDE/PackageEditor.hs view
@@ -0,0 +1,368 @@+-----------------------------------------------------------------------------+--+-- Module      :  IDE.PackageEditor+-- Copyright   :  (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License     :  GNU-GPL+--+-- Maintainer  :  Juergen Nicklisch-Franken <jnf at arcor.de>+-- 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 ()+
+ src/IDE/PackageFlags.hs view
@@ -0,0 +1,209 @@+-----------------------------------------------------------------------------+--+-- Module      :  IDE.PackageFlags+-- Copyright   :  (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License     :  GNU-GPL+--+-- Maintainer  :  Juergen Nicklisch-Franken <jnf at arcor.de>+-- 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 ()+++++++
+ src/IDE/Preferences.hs view
@@ -0,0 +1,350 @@+-----------------------------------------------------------------------------+--+-- Module      :  IDE.Preferences+-- Copyright   :  (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License     :  GNU-GPL+--+-- Maintainer  :  Juergen Nicklisch-Franken <jnf at arcor.de>+-- 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 ()+++
+ src/IDE/PrinterParser.hs view
@@ -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
+ src/IDE/RecoverPanes.hs view
@@ -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 <jnf at arcor.de>+-- 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
+ src/IDE/ReplacePane.hs view
@@ -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 <jnf at arcor.de>+-- 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+++
+ src/IDE/SaveSession.hs view
@@ -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 <jnf at arcor.de>+-- 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+++++
+ src/IDE/SourceCandy.hs view
@@ -0,0 +1,274 @@+-----------------------------------------------------------------------------+--+-- Module      :  IDE.SourceCandy+-- Copyright   :  (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License     :  GNU-GPL+--+-- Maintainer  :  Juergen Nicklisch-Franken <jnf at arcor.de>+-- 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))
+ src/IDE/SourceEditor.hs view
@@ -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 <jnf at arcor.de>+-- 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 "<span foreground=\"red\">" ++ text ++ "</span>"+                          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++++++++
+ src/IDE/SpecialEditors.hs view
@@ -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++++++
+ src/IDE/ToolbarPane.hs view
@@ -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 <jnf at arcor.de>+-- 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)+
+ src/IDE/Utils/DeepSeq.hs view
@@ -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+++++
+ src/IDE/Utils/Default.hs view
@@ -0,0 +1,40 @@++-----------------------------------------------------------------------------+--+-- Module      :  IDE.Utils.Default+-- Copyright   :  (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License     :  GNU-GPL+--+-- Maintainer  :  Juergen Nicklisch-Franken <jnf at arcor.de>+-- 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+
+ src/IDE/Utils/File.hs view
@@ -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)+++++
+ src/Main.hs view
@@ -0,0 +1,4 @@+import IDE.Leksah++main = runMain+