diff --git a/Readme b/Readme --- a/Readme +++ b/Readme @@ -15,22 +15,16 @@ =================== 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 + GHC version 6.10.x + gtk2hs 0.9.14 + other dependencies see cabal file 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. +If you are a user or just test Leksah, we would appreciate to here from you. -Please send questions and suggestions to me: -Jutaro +Please send questions and suggestions to the developers +info(at)leksah(dot)org diff --git a/data/Current.session b/data/Current.session --- a/data/Current.session +++ b/data/Current.session @@ -1,6 +1,9 @@ -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) +Layout: VerticalP (TerminalP (Just LeftP) (-1)) (HorizontalP (TerminalP (Just BottomP) 0) (TerminalP (Just BottomP) 1) 376) 737 +Population: [(Just (LogSt LogState),[RightP,BottomP]),(Just (ModulesSt (ModulesState 335 (Package,True) (Nothing,Nothing))),[RightP,TopP]),(Just (SearchSt (SearchState {searchString = "", searchScope = System, searchMode = Prefix {caseSense = False}})),[RightP,TopP])] +Window size: (1024,780) Active package: Nothing Active pane: Nothing +Toolbar visible: + True +FindbarState: (True,FindState {entryStr = "", entryHist = [], replaceStr = "", replaceHist = [], caseSensitive = False, entireWord = False, wrapAround = True, backward = False, lineNr = 1}) diff --git a/data/Default.candy b/data/Default.candy --- a/data/Default.candy +++ b/data/Default.candy @@ -9,14 +9,17 @@ "&&" 0x2227 --LOGICAL AND "||" 0x2228 --LOGICAL OR "++" 0x2295 --CIRCLED PLUS -"::" 0x2237 --PROPORTION +--"::" 0x2551 Trimming --BAR +"::" 0x2237 Trimming --PROPORTION ".." 0x2025 --TWO DOT LEADER "^" 0x2191 --UPWARDS ARROW -"==" 0x2261 Trimming --IDENTICAL TO ---"." 0x2218 --RING OPERATOR +"==" 0x2261 --IDENTICAL TO +" . " 0x2218 --RING OPERATOR "\" 0x03bb --GREEK SMALL LETTER LAMBDA --"=<<" 0x291e -- ">>=" 0x21a0 +"$" 0x25ca +">>" 0x226b -- MUCH GREATER THEN "forall" 0x2200 --FOR ALL "exist" 0x2203 --THERE EXISTS @@ -26,5 +29,4 @@ "gamma" 0x03b3 "delta" 0x03b4 "epsilon" 0x03b5 - diff --git a/data/Default.keymap b/data/Default.keymap --- a/data/Default.keymap +++ b/data/Default.keymap @@ -5,49 +5,46 @@ --File -n -> FileNew "Opens a new empty buffer" - -o -> FileOpen "Opens an existing file" ---x/f -> FileOpen "Opens an existing file" +n -> FileNew "Opens a new empty buffer" +o -> FileOpen "Opens an existing file" +--x/f -> FileOpen "Opens an existing file" -s -> FileSave "Saves the current buffer" ---x/s -> FileSave "Saves the current buffer" +s -> FileSave "Saves the current buffer" +--x/s -> FileSave "Saves the current buffer" -s -> FileSaveAs "Saves the current buffer as a new file" ---x/w -> FileSaveAs "Saves the current buffer as a new file" +s -> FileSaveAs "Saves the current buffer as a new file" +--x/w -> FileSaveAs "Saves the current buffer as a new file" -w -> FileClose "Closes the current buffer" ---x/k -> FileClose "Closes the current buffer" +w -> FileClose "Closes the current buffer" +--x/k -> FileClose "Closes the current buffer" -F4 -> Quit "Quits this program" ---x/c -> Quit "Quits this program" +F4 -> Quit "Quits this program" +--x/c -> Quit "Quits this program" --Edit -z -> EditUndo "Undos the last user action" ---x/u -> EditUndo "Undos the last user action" +z -> EditUndo "Undos the last user action" +--x/u -> EditUndo "Undos the last user action" -y -> EditRedo "Redos the last user action" ---x/r -> EditRedo "Redos the last user action" +y -> EditRedo "Redos the last user action" +--x/r -> EditRedo "Redos the last user action" ---Just "X" -> EditCut ---Just "C" -> EditCopy ---Just "V" -> EditPaste - -> EditDelete -a -> EditSelectAll "Select the whole text in the current buffer" +--x -> EditCut +--c -> EditCopy +--v -> EditPaste + -> EditDelete +a -> EditSelectAll "Select the whole text in the current buffer" -F3 -> EditFind "Quits this program" -f -> EditFindNext "Search for a text string" +f -> EditFind "Search for a text string (Toggles the " +F3 -> EditFindNext "Find the next occurence of the text string" -f -> EditFindPrevious - "Find the previous occurence of the text string" -r -> EditReplace +F3 -> EditFindPrevious "Find the previous occurence of the text string" -l -> EditGotoLine "Go to line with a known index" +l -> EditGotoLine "Go to line with a known index" -Right -> EditComment "Add a line style comment to the selected lies" -Left -> EditUncomment "Remove a line style comment" -Right -> EditShiftRight "Shift right" -Left -> EditShiftLeft "Shift Left" +Right -> EditComment "Add a line style comment to the selected lies" +Left -> EditUncomment "Remove a line style comment" +Right -> EditShiftRight "Shift right" +Left -> EditShiftLeft "Shift Left" --View Left -> ViewMoveLeft "Move the current pane left" @@ -55,7 +52,7 @@ Up -> ViewMoveUp "Move the current pane up" Down -> ViewMoveDown "Move the current pane down" -2 -> ViewSplitHorizontal +2 -> ViewSplitHorizontal "Split the current pane in horizontal direction" 3 -> ViewSplitVertical "Split the current pane in vertical direction" @@ -66,6 +63,7 @@ -> 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" +t -> ToggleToolbar -> HelpDebug -> HelpAbout @@ -75,3 +73,16 @@ j -> NextError j -> PreviousError + +m -> ShowModules +i -> ShowInterface +i -> ShowInfo + + +e -> EditAlignEqual +l -> EditAlignLeftArrow +r -> EditAlignRightArrow +t -> EditAlignTypeSig + +-- i -> AddOneImport +-- i -> AddAllImports diff --git a/data/Default.menu b/data/Default.menu --- a/data/Default.menu +++ b/data/Default.menu @@ -3,14 +3,14 @@ - - - + + + @@ -21,7 +21,6 @@ - @@ -29,70 +28,82 @@ - - + + + + + + - + + + - - + + + + + + + + + + + + + + + + + + + - - - - - - - - - - + - - - + - + @@ -108,8 +119,6 @@ - - @@ -118,6 +127,10 @@ - + + + + + diff --git a/data/Default.prefs b/data/Default.prefs --- a/data/Default.prefs +++ b/data/Default.prefs @@ -1,26 +1,36 @@ - Show line numbers: True --(True/False) -TextView Font: "" -Right margin: 96 +TextView Font: "Monospace 10" +Right margin: 101 --Size or 0 for no right margin Tab width: 4 Use standard line ends even on windows: True +Remove trailing blanks when saving a file: + 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: "" +Editor Style: "" +LogView Font: "Sans 10" Window default size: (800,800) - --Default size of the main leksah window specified as pair (int,int) + --Default size of the main ide window specified as pair (int,int) Browser: "firefox" -Standard source editor path: - LeftTop +Standard source pane path: + [LeftP] +Standard log pane path: + [RightP,BottomP] +Standard modules pane path: + [RightP,TopP] Paths under which haskell sources for packages may be found: [] Packages which are excluded from the modules pane: - [Dependency "ghc" AnyVersion] + [Dependency (PackageName "ghc") AnyVersion] +Update metadata after every build: + True +Update metadata at startup: + True diff --git a/data/LICENSE b/data/LICENSE new file mode 100644 --- /dev/null +++ b/data/LICENSE @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. diff --git a/data/Module.template b/data/Module.template new file mode 100644 --- /dev/null +++ b/data/Module.template @@ -0,0 +1,21 @@ +----------------------------------------------------------------------------- +-- +-- Module : @ModuleName@ +-- Copyright : @Copyright@ +-- License : @License@ +-- +-- Maintainer : @Maintainer@ +-- Stability : @Stability@ +-- Portability : @Portability@ +-- +-- | +-- +----------------------------------------------------------------------------- + +module @ModuleName@ ( + + +) where + + + diff --git a/data/ide_no_source.png b/data/ide_no_source.png deleted file mode 100644 Binary files a/data/ide_no_source.png and /dev/null differ diff --git a/data/ide_reexported.png b/data/ide_reexported.png new file mode 100644 Binary files /dev/null and b/data/ide_reexported.png differ diff --git a/data/ide_source.png b/data/ide_source.png Binary files a/data/ide_source.png and b/data/ide_source.png differ diff --git a/doc/Todo.txt b/doc/Todo.txt deleted file mode 100644 --- a/doc/Todo.txt +++ /dev/null @@ -1,52 +0,0 @@ -Version 0.1 - -Development - -ok - 1 page Documentation -ok - Add next and previous error (and open package) to toolbar -start - Populate Keystrokes -ok - First start feature - -Bugs - - Dynamic exceptions are not caught - - Double log error - - Slow refresh in Modules pane on 6.8.2 - - Candy bug (e.g. exists) - - Activate Pane switching - - GTK Warnings - - Revert on close (2 times even) - - r does not work for PackageRun - - No horizontal centering for errors in source editor - - (Windows only) Gtk runs out of memory and does not displayx correctly ??? - _win32_scaled_font_set_world_transform: Für diesen Befehl ist nicht genügend Speicher verfügbar. - Doesn't happen with Raleigh Theme in Gtk2Hs\etc\gtk-2.0 - - Changed red color not preserved when moving panes - - Collector: No reexported declarations. - - Collector: Getting Instances types right - - empty lines in shift left/right - -ok - Sort field in Info Pane doesn't work - - Sort order of interfaces in module pane? - = Reverse order source collector bug - -Version 0.x - - - Search in interface tree - - Working Cabal Editor with Configurations (etc..) "Change" - - Completion - - Search - - Class Hierarchy pane - - Import helper - - Editor; Highliting according to file type - - Editor Templates for new files - - Properties of single editor (no highlight, no candy,...) - - Haddock (deferr to Haddock 2.0) - - Generic record editor - - Using find in sources without location - - Build only one time - Cancel build - - Source collector only one time - Make it run in background - - Preferences embedden - - Uses Pane - - - diff --git a/doc/leksah_manual.pdf b/doc/leksah_manual.pdf Binary files a/doc/leksah_manual.pdf and b/doc/leksah_manual.pdf differ diff --git a/leksah.cabal b/leksah.cabal --- a/leksah.cabal +++ b/leksah.cabal @@ -1,72 +1,74 @@ name: leksah -version: 0.1.1 -cabal-version: >= 1.2 +version: 0.4 +cabal-version: >=1.4 build-type: Custom license: GPL license-file: LICENSE -copyright: 2007 Juergen Nicklisch-Franken -maintainer: Juergen Nicklisch-Franken +copyright: 2007-2009 Jürgen Nicklisch-Franken +maintainer: Jutaro +build-depends: regex-posix >=0.72.0.3, utf8-string >=0.3.1.1, + bytestring >=0.9.0.1, binary >=0.4.4, ghc >=6.10.1, glib >=0.10, + gtk >=0.10, directory >=1.0.0.2, pretty >=1.0.1.0, + containers >=0.2.0.0, process >=1.0.1.0, mtl >=1.1.0.2, + parsec >=2.1.0.1, Cabal >=1.6.0.1, filepath >=1.1.0.1, + base >=4.0.0.0, old-time >=1.0.0.1, gtksourceview2 >=0.10.0 stability: provisional -homepage: -package-url: http://code.haskell.org/leksah +homepage: http://www.leksah.org +package-url: http://code.haskell.org/leksah +bug-reports: synopsis: Haskell IDE written in Haskell description: An Integrated Development Environment for Haskell written in Haskell. -category: Development -author: Jutaro (Juergen Nicklisch-Franken) +category: Development, IDE, Editor +author: Jutaro +tested-with: GHC ==6.10.1 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 + 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_reexported.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 Readme LICENSE data/LICENSE + data/Module.template +data-dir: "" 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: + +executable: leksah +main-is: Main.hs +buildable: True +build-tools: +cpp-options: +cc-options: +ld-options: +pkgconfig-depends: +frameworks: +c-sources: +extensions: CPP +extra-libraries: +extra-lib-dirs: +includes: +install-includes: +include-dirs: +hs-source-dirs: src +other-modules: MyMissing DeepSeq Default Control.Event + Graphics.UI.Editor.Parameters Graphics.UI.Editor.Composite + Graphics.UI.Editor.Basics Graphics.UI.Editor.MakeEditor + Graphics.UI.Editor.Simple Graphics.UI.Frame.ViewFrame + Graphics.UI.Frame.Panes IDE.Leksah IDE.PrinterParser IDE.FileUtils + IDE.Menu IDE.DescriptionPP IDE.Find IDE.SourceCandy IDE.Package + IDE.SpecialEditors IDE.GUIHistory IDE.SaveSession IDE.Keymap + IDE.Exception IDE.Pane.Modules IDE.Pane.PackageEditor IDE.Pane.Log + IDE.Pane.Search IDE.Pane.Info IDE.Pane.SourceBuffer + IDE.Pane.Preferences IDE.Pane.Callers IDE.Pane.ClassHierarchy + IDE.Pane.PackageFlags IDE.Metainfo.SourceCollector + IDE.Metainfo.Provider IDE.Metainfo.InterfaceCollector + IDE.Core.Types IDE.Core.State +ghc-prof-options: -prof -auto-all +ghc-shared-options: -prof -auto-all +ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns -O2 +hugs-options: +nhc98-options: +jhc-options: diff --git a/src/Control/Event.hs b/src/Control/Event.hs new file mode 100644 --- /dev/null +++ b/src/Control/Event.hs @@ -0,0 +1,86 @@ +{-# OPTIONS_GHC -XMultiParamTypeClasses -XFunctionalDependencies #-} +----------------------------------------------------------------------------- +-- +-- Module : Control.Event +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | A simple event mechanism +-- +------------------------------------------------------------------------------- +module Control.Event ( + EventSelector +, Event(..) +, EventSource(..) +, Handlers +) where + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Unique +import Control.Monad + +-- | Every event needs a selector, which should identify the type of event +class (Eq delta, Ord delta, Show delta) => EventSelector delta + +-- | Every event needs to know its selector and its source +class EventSelector delta => Event beta delta | beta -> delta, delta -> beta where + getSelector :: beta -> delta + +-- | This shows the implementation of the event mechnism +type Handlers beta gamma delta = Map delta [(Unique, beta -> gamma beta)] + +-- | Everything which is an event source needs this +class (Monad gamma, Event beta delta) => EventSource alpha beta gamma delta + | alpha -> beta, alpha -> gamma where + getHandlers :: alpha -> gamma (Handlers beta gamma delta) + setHandlers :: alpha -> Handlers beta gamma delta -> gamma () + myUnique :: alpha -> gamma (Unique) + + -- | Reimplement this in instances to make triggering of events possible + canTriggerEvent :: alpha -> delta -> Bool + canTriggerEvent _ _ = False + + -- | Returns the event, so that you may get values back from an event + triggerEvent :: alpha -> beta -> gamma beta + triggerEvent o e = + if canTriggerEvent o (getSelector e) + then do + handlerMap <- getHandlers o + let selector = getSelector e + case selector `Map.lookup` handlerMap of + Nothing -> return e + Just l -> foldM (\e (_,ah) -> ah e) e (reverse l) + else error $ "Can't trigger event " ++ show (getSelector e) + + -- | use Left to register and Right to unregister + -- returns Unique if registration was successfull, else Nothing + registerEvent :: alpha -> delta + -> Either (beta -> gamma beta) Unique -> gamma (Maybe Unique) + registerEvent o e (Left handler) = + if canTriggerEvent o e + then do + handlerMap <- getHandlers o + unique <- myUnique o + let newHandlers = case e `Map.lookup` handlerMap of + Nothing -> Map.insert e [(unique,handler)] handlerMap + Just l -> Map.insert e ((unique,handler):l) handlerMap + setHandlers o newHandlers + return (Just unique) + else return Nothing + registerEvent o e (Right unique) = + if canTriggerEvent o e + then do + handlerMap <- getHandlers o + 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 + setHandlers o newHandlers + return (Just unique) + else return Nothing + diff --git a/src/DeepSeq.hs b/src/DeepSeq.hs new file mode 100644 --- /dev/null +++ b/src/DeepSeq.hs @@ -0,0 +1,60 @@ +module 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) = deepSeq a $ deepSeq b + +instance (DeepSeq a,DeepSeq b,DeepSeq c) => DeepSeq (a,b,c) where + deepSeq (a,b,c) = deepSeq a $ deepSeq b $ deepSeq c + +instance (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d) => DeepSeq (a,b,c,d) where + deepSeq (a,b,c,d) = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d + +instance (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d,DeepSeq e) => DeepSeq (a,b,c,d,e) where + deepSeq (a,b,c,d,e) = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d $ deepSeq e + +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) = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d $ deepSeq e $ deepSeq f + +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) = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d $ deepSeq e $ deepSeq f $ deepSeq g + + + + + diff --git a/src/Default.hs b/src/Default.hs new file mode 100644 --- /dev/null +++ b/src/Default.hs @@ -0,0 +1,42 @@ + +----------------------------------------------------------------------------- +-- +-- Module : Default +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | Module for default values of a data type +-- +------------------------------------------------------------------------------ + +module 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 + +instance Default Bool where + getDefault = True diff --git a/src/Graphics/UI/Editor/Basics.hs b/src/Graphics/UI/Editor/Basics.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Editor/Basics.hs @@ -0,0 +1,288 @@ +{-# OPTIONS_GHC -XMultiParamTypeClasses -XScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- +-- Module : Graphics.UI.Editor.Basics +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | Module for the basiscs of composing GUIs from editors +-- +----------------------------------------------------------------------------------- + +module Graphics.UI.Editor.Basics ( +-- * Types + Getter +, Setter +, Injector +, Extractor +, Applicator +, Editor +, getStandardRegFunction +, emptyNotifier +, GUIEvent(..) +, GUIEventSelector(..) +, GtkRegFunc +, Notifier(..) +, GtkHandler + +, activateEvent +, propagateEvent +, allGUIEvents +) where + +import Graphics.UI.Gtk +import qualified Graphics.UI.Gtk.Gdk.Events as Gtk +import Data.Unique +import Data.IORef +import Control.Monad + +--import Debug.Trace + +import Graphics.UI.Editor.Parameters +import Control.Event +import MyMissing(allOf) +import Data.Map (Map(..)) +import qualified Data.Map as Map (delete,insert,lookup,empty) +import Data.Maybe (isJust,fromJust) +import Unsafe.Coerce (unsafeCoerce) +import Control.Arrow (first) + + +-- --------------------------------------------------------------------- +-- * 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)) +-- +-- | A type for the application of a value to be reflected in the GUI +-- +type Applicator beta gamma = beta -> gamma () + +-- +-- | A type to describe an editor. +-- alpha is the type of the individual field of the record +type Editor alpha = Parameters -> Notifier + -> IO(Widget, Injector alpha , Extractor alpha) + + +-- +-- | A type for an event in the GUI +-- +data GUIEvent = GUIEvent { + selector :: GUIEventSelector +, gtkEvent :: Gtk.Event +, eventPaneName :: String +, gtkReturn :: Bool -- ^ True means that the event has been completely handled, + -- gtk shoudn't do any further action about it (Often not + -- a good idea +} +instance Event GUIEvent GUIEventSelector where + getSelector = selector + +data GUIEventSelector = Clicked + | FocusOut + | FocusIn + | SelectionChanged + | ButtonRelease + | AfterKeyRelease + deriving (Eq,Ord,Show,Enum,Bounded) + +instance EventSelector GUIEventSelector + +allGUIEvents :: [GUIEventSelector] +allGUIEvents = allOf + +-- ------------------------------------------------------------ +-- * Implementation of GUI event system +-- ------------------------------------------------------------ + +-- | A type for handling an IO event +-- Returning True: The event has been handles +-- Returning False: Handling should proceed +type GtkHandler = Gtk.Event -> IO Bool + +-- +-- | A type for a function to register a gtk event +-- | +type GtkRegFunc = Widget -> GtkHandler -> IO (ConnectId Widget) + +-- +-- | The widgets are the real event sources. +-- The GtkRegFunc is the function used to register the event. +-- The connectIds are set, when the event is activated, and +-- can be used to deactivate the event. +-- Or it is a propagated event and: +-- The Notifier List is a list of event sources, to which registrations +-- are propageted. +-- The last map is used to unregister propagated events properly +-- +type GUIEventReg = ([ConnectId Widget], + ([Notifier], Map Unique [(Unique,Notifier)])) + +-- +-- | The event source in the gtk editor context +-- 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 +newtype Notifier = Noti (IORef (Handlers GUIEvent IO GUIEventSelector, + Map GUIEventSelector GUIEventReg)) + + +emptyNotifier :: IO Notifier +emptyNotifier = do + h <- newIORef (Map.empty,Map.empty) + let noti = Noti h + return noti + +instance EventSource Notifier GUIEvent IO GUIEventSelector where + getHandlers (Noti pairRef) = do + (h,_) <- readIORef pairRef + return h + + setHandlers (Noti pairRef) h = do + (_,r) <- readIORef pairRef + writeIORef pairRef (h,r) + + myUnique _ = newUnique + + canTriggerEvent _ _ = True + + registerEvent o@(Noti pairRef) eventSel hand@(Left handler) = do + (handlers, ger) <- readIORef pairRef + unique <- myUnique o + newGer <- case Map.lookup eventSel ger of + Nothing -> return ger + Just (_,([],um)) -> return ger + Just (cids,(notifiers,um)) -> do + lu <- mapM (\es -> registerEvent es eventSel hand) + notifiers + let jl = map (first fromJust) + $ filter (isJust.fst) + $ zip lu notifiers + let newUm = Map.insert unique jl um + return (Map.insert eventSel (cids,(notifiers,newUm)) ger) + let newHandlers = case eventSel `Map.lookup` handlers of + Nothing -> Map.insert eventSel + [(unique,handler)] handlers + Just l -> Map.insert eventSel + ((unique,handler):l) handlers + writeIORef pairRef (newHandlers,newGer) + return (Just unique) + registerEvent o@(Noti pairRef) eventSel (Right unique) = do + (handlers, ger) <- readIORef pairRef + newGer <- case Map.lookup eventSel ger of + Nothing -> return ger + Just (cids,(notis,um)) -> + case unique `Map.lookup` um of + Nothing -> return ger + Just l -> do + mapM_ (\(u,es) -> registerEvent es eventSel (Right u)) l + let newUm = unique `Map.delete` um + return (Map.insert eventSel (cids,(notis,newUm)) ger) + let newHandlers = case eventSel `Map.lookup` handlers of + Nothing -> handlers + Just l -> case filter (\ (mu,_) -> mu /= unique) l of + [] -> Map.delete eventSel handlers + l -> Map.insert eventSel l handlers + writeIORef pairRef (newHandlers,newGer) + return (Just unique) + +-- +-- | Propagate the event with the selector from notifier to eventSource +-- +propagateEvent :: Notifier -> [Notifier] -> GUIEventSelector -> IO () +propagateEvent (Noti pairRef) eventSources eventSel = do + (handlers,ger) <- readIORef pairRef + let newGer = case Map.lookup eventSel ger of + Nothing -> Map.insert eventSel + ([],(eventSources,Map.empty)) ger + Just (w,(notiList,unregMap)) -> Map.insert eventSel + (w,(eventSources ++ notiList,unregMap)) ger + --now propagate already registered events + newGer2 <- case eventSel `Map.lookup` handlers of + Nothing -> return newGer + Just hl -> foldM (repropagate eventSel) newGer hl + writeIORef pairRef (handlers,newGer) + where + repropagate :: GUIEventSelector + -> Map GUIEventSelector GUIEventReg + -> (Unique, GUIEvent -> IO GUIEvent) + -> IO (Map GUIEventSelector GUIEventReg) + repropagate eventSet ger (unique,hand) = + case Map.lookup eventSel ger of + Just (cids,(notifiers,um)) + -> do + lu <- mapM (\es -> registerEvent es eventSel (Left hand)) + notifiers + let jl = map (first fromJust) + $ filter (isJust.fst) + $ zip lu notifiers + let newUm = Map.insert unique jl um + return (Map.insert eventSel (cids,(notifiers,newUm)) ger) + _ -> error "Basics>>propagateEvent: impossible case" + +-- +-- | Activate the event after the event has been declared and the +-- widget has been constructed +-- +activateEvent :: Widget -> Notifier -> Maybe GtkRegFunc -> GUIEventSelector -> IO() +activateEvent widget (Noti pairRef) mbRegisterFunc eventSel = do + let registerFunc = case mbRegisterFunc of + Just f -> f + Nothing -> getStandardRegFunction eventSel + cid <- registerFunc widget (\ e -> do + (hi,_) <- readIORef pairRef + case Map.lookup eventSel hi of + Nothing -> return False + Just [] -> return False + Just handlers -> do + name <- widgetGetName widget + eventList <- mapM (\f -> do + let ev = GUIEvent eventSel e name False + f ev) + (map snd handlers) + let boolList = map gtkReturn eventList + return (foldr (&&) True boolList)) + (handerls,ger) <- readIORef pairRef + let newGer = case Map.lookup eventSel ger of + Nothing -> Map.insert eventSel ([cid],([],Map.empty)) + ger + Just (cids,prop) -> + Map.insert eventSel (cid:cids,prop) ger + writeIORef pairRef (handerls,newGer) + +-- +-- | A convinence method for not repeating this over and over again +-- +getStandardRegFunction :: GUIEventSelector -> GtkRegFunc +getStandardRegFunction FocusOut = \w h -> w `onFocusOut` h +getStandardRegFunction FocusIn = \w h -> w `onFocusIn` h +getStandardRegFunction ButtonRelease = \w h -> w `onButtonRelease` h +getStandardRegFunction AfterKeyRelease = \w h -> w `afterKeyRelease` h +getStandardRegFunction Clicked = \w h -> do + res <- onClicked (castToButton w) (do + h (Gtk.Event True) + return ()) + return (unsafeCoerce res) +getStandardRegFunction SelectionChanged = error "yet not implemented" diff --git a/src/Graphics/UI/Editor/Composite.hs b/src/Graphics/UI/Editor/Composite.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Editor/Composite.hs @@ -0,0 +1,453 @@ +----------------------------------------------------------------------------- +-- +-- Module : Graphics.UI.Editor.Composite +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | Module for making composite editors +-- +----------------------------------------------------------------------------------- + +module Graphics.UI.Editor.Composite ( + maybeEditor +, pairEditor +, splitEditor +, 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 Default +import IDE.Exception +import Control.Event +import Graphics.UI.Editor.Parameters +import Graphics.UI.Editor.Basics +import Graphics.UI.Editor.MakeEditor +import Graphics.UI.Editor.Simple + +-- +-- | An editor which composes two subeditors +-- +pairEditor :: (Editor alpha, Parameters) -> (Editor beta, Parameters) -> Editor (alpha,beta) +pairEditor (fstEd,fstPara) (sndEd,sndPara) parameters notifier = do + coreRef <- newIORef Nothing + noti1 <- emptyNotifier + noti2 <- emptyNotifier + mapM_ (propagateEvent notifier [noti2]) allGUIEvents + fst@(fstFrame,inj1,ext1) <- fstEd fstPara noti1 + snd@(sndFrame,inj2,ext2) <- sndEd sndPara noti2 + mkEditor + (\widget (v1,v2) -> do + core <- readIORef coreRef + case core of + Nothing -> do + 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 + 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) + parameters + notifier + +-- +-- | Like a pair editor, but with a moveable split +-- +splitEditor :: (Editor alpha, Parameters) -> (Editor beta, Parameters) -> Editor (alpha,beta) +splitEditor (fstEd,fstPara) (sndEd,sndPara) parameters notifier = do + coreRef <- newIORef Nothing + noti1 <- emptyNotifier + noti2 <- emptyNotifier + mapM_ (propagateEvent notifier [noti1,noti2]) allGUIEvents + fst@(fstFrame,inj1,ext1) <- fstEd fstPara noti1 + snd@(sndFrame,inj2,ext2) <- sndEd sndPara noti2 + mkEditor + (\widget (v1,v2) -> do + core <- readIORef coreRef + case core of + Nothing -> do + paned <- case getParameter paraDirection parameters of + Horizontal -> do h <- vPanedNew + return (castToPaned h) + Vertical -> do v <- hPanedNew + return (castToPaned v) + panedPack1 paned fstFrame True True + panedPack2 paned sndFrame True True + containerAdd widget paned + 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) + parameters + notifier + +-- +-- | 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 notifier = do + coreRef <- newIORef Nothing + childRef <- newIORef Nothing + notifierBool <- emptyNotifier + cNoti <- emptyNotifier + mapM_ (propagateEvent notifier [notifierBool]) [Clicked,FocusIn] + mapM_ (propagateEvent notifier [cNoti]) allGUIEvents + + mkEditor + (\widget mbVal -> do + core <- readIORef coreRef + case core of + Nothing -> do + box <- case getParameter paraDirection parameters of + Horizontal -> do + b <- hBoxNew False 1 + return (castToBox b) + Vertical -> do + b <- vBoxNew False 1 + return (castToBox b) + be@(boolFrame,inj1,ext1) <- boolEditor + (paraName <<<- ParaName boolLabel $ emptyParams) + notifierBool + boxPackStart box boolFrame PackNatural 0 + containerAdd widget box + registerEvent notifierBool Clicked (Left (onClickedHandler widget coreRef childRef cNoti)) + case mbVal of + Nothing -> inj1 (not positive) + Just val -> do + (childWidget,inj2,ext2) <- getChildEditor childRef childEdit childParams cNoti + boxPackEnd box childWidget PackGrow 0 + widgetShowAll childWidget + inj1 positive + inj2 val + writeIORef coreRef (Just (be,box)) + Just (be@(boolFrame,inj1,extt),box) -> do + hasChild <- hasChildEditor childRef + case mbVal of + Nothing -> + if hasChild + then do + (childWidget,_,_) <- getChildEditor childRef childEdit childParams cNoti + inj1 (not positive) + widgetHideAll childWidget + else inj1 (not positive) + Just val -> + if hasChild + then do + (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti + widgetShowAll childWidget + inj2 val + else do + (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti + boxPackEnd box childWidget PackGrow 0 + widgetShowAll childWidget + inj2 val) + (do + core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just (be@(boolFrame,inj1,ext1),_) -> do + bool <- ext1 + case bool of + Nothing -> return Nothing + Just bv | bv == positive -> do + (_,_,ext2) <- getChildEditor childRef childEdit childParams cNoti + value <- ext2 + case value of + Nothing -> return Nothing + Just value -> return (Just (Just value)) + otherwise -> return (Just Nothing)) + parameters + notifier + where + onClickedHandler widget coreRef childRef cNoti event = do + core <- readIORef coreRef + case core of + Nothing -> throwIDE "Impossible" + Just (be@(boolFrame,inj1,ext1),vBox) -> do + mbBool <- ext1 + case mbBool of + Just bool -> + if bool /= positive + then do + hasChild <- hasChildEditor childRef + when hasChild $ do + (childWidget,_,_) <- getChildEditor childRef childEdit childParams cNoti + widgetHideAll childWidget + else do + hasChild <- hasChildEditor childRef + if hasChild + then do + (childWidget,_,_) <- getChildEditor childRef childEdit childParams cNoti + widgetShowAll childWidget + else do + (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti + boxPackEnd vBox childWidget PackNatural 0 + inj2 getDefault + widgetShowAll childWidget + Nothing -> return () + return (event {gtkReturn=True}) + getChildEditor childRef childEditor childParams cNoti = do + mb <- readIORef childRef + case mb of + Just editor -> return editor + Nothing -> do + let val = childEditor + editor@(_,_,_) <- childEditor childParams cNoti + 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 notifier = do + coreRef <- newIORef Nothing + noti1 <- emptyNotifier + noti2 <- emptyNotifier + noti3 <- emptyNotifier + mapM_ (propagateEvent notifier [noti1,noti2,noti3]) allGUIEvents + be@(boolFrame,inj1,ext1) <- boolEditor2 label2 parameters noti1 + le@(leftFrame,inj2,ext2) <- leftEditor leftParams noti2 + re@(rightFrame,inj3,ext3) <- rightEditor rightParams noti3 + mkEditor + (\widget v -> do + core <- readIORef coreRef + case core of + Nothing -> do + registerEvent noti1 Clicked (Left (onClickedHandler widget coreRef)) + 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 + 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) -> + 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))) + (paraName <<<- ParaName "" $ parameters) + notifier + 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 event{gtkReturn=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 notifier = do + coreRef <- newIORef Nothing + cnoti <- emptyNotifier + mapM_ (propagateEvent notifier [cnoti]) allGUIEvents + 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) <- singleEditor sParams cnoti + addButton <- buttonNewWithLabel "Add" + removeButton <- buttonNewWithLabel "Remove" + containerAdd buttonBox addButton + containerAdd buttonBox removeButton + listStore <- New.listStoreNew ([]:: [alpha]) + list <- New.treeViewNewWithModel listStore + let minSize = getParameter paraMinSize parameters + uncurry (widgetSetSizeRequest list) minSize + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw list + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + 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 sw PackGrow 0 + boxPackStart box buttonBox PackNatural 0 + boxPackStart box frameS PackNatural 0 + activateEvent (castToWidget list) notifier Nothing FocusOut + containerAdd widget box + New.listStoreClear listStore + mapM_ (New.listStoreAppend listStore) v + addButton `onClicked` do + mbv <- extS + case mbv of + Just v -> do + seq <- New.listStoreAppend listStore v + New.treeSelectionSelectPath sel [seq] + mbCol <- treeViewGetColumn list 0 + case mbCol of + Nothing -> return () + Just col -> New.treeViewScrollToCell list [seq] col Nothing + 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)) + (paraMinSize <<<- ParaMinSize (-1,-1) $ parameters) + notifier + where + listStoreGetValues :: New.ListStore a -> IO [a] + listStoreGetValues listStore = New.treeModelGetIterFirst listStore >>= getTail + where getTail mbi = case mbi of + Nothing -> return [] + Just iter -> do + [i] <- New.treeModelGetPath listStore iter + v <- New.listStoreGetValue listStore i + mbi2 <- New.treeModelIterNext listStore iter + rest <- getTail mbi2 + return (v : rest) + selectionHandler :: New.TreeSelection -> New.ListStore a -> Injector a -> IO () + selectionHandler sel listStore inj = do + ts <- New.treeSelectionGetSelected sel + case ts of + Nothing -> return () + Just iter -> do + [i] <- New.treeModelGetPath listStore iter + v <- New.listStoreGetValue listStore i + inj v + return () + diff --git a/src/Graphics/UI/Editor/MakeEditor.hs b/src/Graphics/UI/Editor/MakeEditor.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Editor/MakeEditor.hs @@ -0,0 +1,241 @@ +----------------------------------------------------------------------------- +-- +-- Module : Graphics.UI.Editor.MakeEditor +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | Module for making editors out of descriptions +-- +----------------------------------------------------------------------------------- + +module Graphics.UI.Editor.MakeEditor ( + + buildEditor +, FieldDescription(..) +, mkField +, extractAndValidate +, extract +, mkEditor +, parameters + +, flattenFieldDescription +, getRealWidget +, MkFieldDescription + +) where + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.ModelView as New +import Control.Monad +import Data.List(unzip4) + +import Control.Event +import Graphics.UI.Editor.Parameters +import Graphics.UI.Editor.Basics +import Graphics.UI.Frame.ViewFrame +import Data.Maybe (isNothing) + +-- +-- | 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 (alpha -> IO (Widget, Injector alpha , + alpha -> Extractor alpha , Notifier)) + | VFD Parameters [FieldDescription alpha] + | HFD Parameters [FieldDescription alpha] + | NFD [(String,FieldDescription alpha)] + +parameters :: FieldDescription alpha -> Parameters +parameters (FD p _) = p +parameters (VFD p _) = p +parameters (HFD p _) = p +parameters (NFD _) = emptyParams + +buildEditor :: FieldDescription alpha -> alpha -> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier) +buildEditor (FD paras editorf) v = editorf v +buildEditor (HFD paras descrs) v = buildBoxEditor descrs Horizontal v +buildEditor (VFD paras descrs) v = buildBoxEditor descrs Vertical v +buildEditor (NFD pairList) v = do + nb <- newNotebook + notebookSetShowTabs nb False + resList <- mapM (\d -> buildEditor d v) (map snd pairList) + let (widgets, setInjs, getExts, notifiers) = unzip4 resList + notifier <- emptyNotifier + mapM_ (\ (labelString, widget) -> do + sw <- scrolledWindowNew Nothing Nothing + scrolledWindowAddWithViewport sw widget + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + notebookAppendPage nb sw labelString) + (zip (map fst pairList) widgets) + listStore <- New.listStoreNew (map fst pairList) + listView <- New.treeViewNewWithModel listStore + widgetSetSizeRequest listView 100 (-1) + sel <- New.treeViewGetSelection listView + New.treeSelectionSetMode sel SelectionSingle + renderer <- New.cellRendererTextNew + col <- New.treeViewColumnNew + New.treeViewAppendColumn listView col + New.cellLayoutPackStart col renderer True + New.cellLayoutSetAttributes col renderer listStore $ \row -> + [ New.cellText := row ] + New.treeViewSetHeadersVisible listView False + New.treeSelectionSelectPath sel [0] + notebookSetCurrentPage nb 0 + sel `New.onSelectionChanged` (do + selections <- New.treeSelectionGetSelectedRows sel + case selections of + [[i]] -> notebookSetCurrentPage nb i + _ -> return ()) + + hb <- hBoxNew False 0 + boxPackStart hb listView PackNatural 7 + boxPackEnd hb nb PackGrow 7 + let newInj = (\v -> mapM_ (\ setInj -> setInj v) setInjs) + let newExt = (\v -> extract v getExts) + mapM_ (propagateEvent notifier notifiers) allGUIEvents + return (castToWidget hb, newInj, newExt, notifier) + +buildBoxEditor :: [FieldDescription alpha] -> Direction -> alpha + -> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier) +buildBoxEditor descrs dir v = do + resList <- mapM (\d -> buildEditor d v) descrs + notifier <- emptyNotifier + let (widgets, setInjs, getExts, notifiers) = unzip4 resList + hb <- case dir of + Horizontal -> do + b <- hBoxNew False 0 + return (castToBox b) + Vertical -> do + b <- vBoxNew False 0 + return (castToBox b) + let newInj = (\v -> mapM_ (\ setInj -> setInj v) setInjs) + let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of + Just s -> s + Nothing -> "Unnamed") descrs + let packParas = map (\fd -> getParameter paraPack (parameters fd)) descrs + let newExt = (\v -> extractAndValidate v getExts fieldNames) + mapM_ (\ (w,p) -> boxPackStart hb w p 0) $ zip widgets packParas + mapM_ (propagateEvent notifier notifiers) allGUIEvents + return (castToWidget hb, newInj, newExt, notifier) + + +flattenFieldDescription :: FieldDescription alpha -> [FieldDescription alpha] +flattenFieldDescription (VFD paras descrs) = concatMap flattenFieldDescription descrs +flattenFieldDescription (HFD paras descrs) = concatMap flattenFieldDescription descrs +flattenFieldDescription (NFD descrp) = concatMap (flattenFieldDescription.snd) descrp +flattenFieldDescription fd = [fd] + +-- ------------------------------------------------------------ +-- * Implementation of editing +-- ------------------------------------------------------------ + +-- +-- | Function to construct a field description +-- +mkField :: Eq beta => MkFieldDescription alpha beta +mkField parameters getter setter editor = + FD parameters + (\ dat -> do + noti <- emptyNotifier + (widget,inj,ext) <- editor parameters noti + let pext = (\a -> do + b <- ext + case b of + Just b -> return (Just (setter b a)) + Nothing -> return Nothing) + registerEvent noti FocusOut (Left (\e -> do + let name = eventPaneName e + e2 <- ext + when (isNothing e2) $ do + md <- messageDialogNew Nothing [] MessageWarning ButtonsClose + $ "The field " ++ name ++ " has an invalid value " + dialogRun md + widgetDestroy md + return (e{gtkReturn=False}))) + inj (getter dat) + return (widget, + (\a -> inj (getter a)), + pext, + noti)) + +-- | Function to construct an editor +-- +mkEditor :: (Container -> Injector alpha) -> Extractor alpha -> Editor alpha +mkEditor injectorC extractor parameters notifier = 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 + let name = getParameter paraName parameters + widgetSetName outerAlig name + let build = injectorC (castToContainer innerAlig) + return (castToWidget outerAlig, build, extractor) + +-- | 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 = + foldM (\ mbVal ext -> + case mbVal of + Nothing -> return Nothing + Just val -> ext val) + (Just val) + +-- | get through outerAlignment, frame, innerAlignment +getRealWidget :: Widget -> IO (Maybe Widget) +getRealWidget w = do + mbF <- binGetChild (castToBin w) + case mbF of + Nothing -> return Nothing + Just f -> do + mbIA <- binGetChild (castToBin f) + case mbIA of + Nothing -> return Nothing + Just iA -> binGetChild (castToBin iA) + + + + diff --git a/src/Graphics/UI/Editor/Parameters.hs b/src/Graphics/UI/Editor/Parameters.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Editor/Parameters.hs @@ -0,0 +1,178 @@ +----------------------------------------------------------------------------- +-- +-- Module : Graphics.UI.Editor.Parameters +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | Module for parameters for editors +-- +----------------------------------------------------------------------------------- + +module Graphics.UI.Editor.Parameters ( + Parameters +, Parameter(..) +, paraName +, paraSynopsis +, paraDirection +, paraShadow +, paraOuterAlignment +, paraInnerAlignment +, paraOuterPadding +, paraInnerPadding +, paraMinSize +, paraHorizontal +, paraStockId +, paraMultiSel +, paraPack + +, getParameter +, getParameterPrim +, (<<<-) +, emptyParams +, Direction(..) +, HorizontalAlign(..) +) where + +import Graphics.UI.Gtk +import Data.Maybe +import qualified Data.List as List + +import IDE.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 + | ParaStockId String + | ParaMultiSel Bool + | ParaPack Packing + deriving (Eq,Show) + + +{-- #if MIN_VERSION_gtk(0,9,13) + -- now defined in gtk + #else + instance Show ShadowType + where show _ = "Any Shadow" + #endif +--} + +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 + +paraStockId :: (Parameter -> (Maybe String)) +paraStockId (ParaStockId str) = Just str +paraStockId _ = Nothing + +paraMultiSel :: (Parameter -> (Maybe Bool)) +paraMultiSel (ParaMultiSel b) = Just b +paraMultiSel _ = Nothing + +paraPack :: (Parameter -> (Maybe Packing)) +paraPack (ParaPack b) = Just b +paraPack _ = 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 "" + , ParaStockId "" + , ParaSynopsis "" + , ParaDirection Horizontal + , ParaShadow ShadowNone + , ParaOuterAlignment (0.4, 0.5, 1.0, 0.7) + , ParaOuterPadding (5, 5, 5, 5) + , ParaInnerAlignment (0.4, 0.5, 1.0, 0.7) + , ParaInnerPadding (5, 5, 5, 5) + , ParaMinSize (-1,-1) + , ParaHorizontal Keep + , ParaMultiSel True + , ParaPack PackNatural + ] + diff --git a/src/Graphics/UI/Editor/Simple.hs b/src/Graphics/UI/Editor/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Editor/Simple.hs @@ -0,0 +1,610 @@ +----------------------------------------------------------------------------- +-- +-- Module : Graphics.UI.Editor.Simple +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | Module for making simple editors +-- +----------------------------------------------------------------------------------- + +module Graphics.UI.Editor.Simple ( + boolEditor +, boolEditor2 +, clickEditor +, stringEditor +, multilineStringEditor +, intEditor +, genericEditor +, fontEditor +, comboSelectionEditor +, staticListEditor +, multiselectionEditor +, fileEditor +, otherEditor +, imageEditor + +, okCancelFields +) where + +import Graphics.UI.Gtk +import qualified Graphics.UI.Gtk as Gtk +import Graphics.UI.Gtk.ModelView as New +import IDE.Core.State (MessageLevel(..)) +import IDE.Core.State (sysMessage) +import Control.Monad +import Data.IORef +import Data.List +import Data.Maybe +import System.FilePath.Posix + +import Graphics.UI.Editor.Parameters +import Graphics.UI.Editor.Basics +import Graphics.UI.Editor.MakeEditor +import Control.Event + +-- ------------------------------------------------------------ +-- * 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 notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget bool -> do + core <- readIORef coreRef + case core of + Nothing -> do + button <- checkButtonNewWithLabel (getParameter paraName parameters) + widgetSetName button (getParameter paraName parameters) + containerAdd widget button + toggleButtonSetActive button bool + mapM_ (activateEvent (castToWidget button) notifier Nothing) + [Clicked,FocusOut,FocusIn] + 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)) + (paraName <<<- ParaName "" $ parameters) + notifier + +-- +-- | Editor for a boolean value in the form of two radio buttons +-- +boolEditor2 :: String -> Editor Bool +boolEditor2 label2 parameters notifier = do + coreRef <- newIORef Nothing + 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 + widgetSetName radio1 $ getParameter paraName parameters ++ ".1" + widgetSetName radio2 $ getParameter paraName parameters ++ ".2" + containerAdd widget box + if bool + then toggleButtonSetActive radio1 True + else toggleButtonSetActive radio2 True + mapM_ (activateEvent (castToWidget radio1) notifier Nothing) + [Clicked,FocusOut,FocusIn] + mapM_ (activateEvent (castToWidget radio2) notifier Nothing) + [Clicked,FocusOut,FocusIn] + writeIORef coreRef (Just (radio1,radio2)) + Just (radio1,radio2) -> + if bool + then toggleButtonSetActive radio1 True + else toggleButtonSetActive radio2 True) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just (radio1,radio2) -> do + r <- toggleButtonGetActive radio1 + return (Just r)) + (paraName <<<- ParaName "" $ parameters) + notifier + +-- | An Editor for nothing (which may report a click) in the form of a button +-- +clickEditor :: Editor () +clickEditor parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget bool -> do + core <- readIORef coreRef + case core of + Nothing -> do + button <- case getParameter paraStockId parameters of + "" -> buttonNewWithLabel (getParameter paraName parameters) + st -> buttonNewFromStock st + widgetSetName button (getParameter paraName parameters) + containerAdd widget button + activateEvent (castToWidget button) notifier Nothing Clicked + writeIORef coreRef (Just button) + Just button -> return ()) + (return (Just ())) + (paraName <<<- ParaName "" $ parameters) + notifier + +-- | An Editor to display an image +-- +imageEditor :: Editor StockId +imageEditor parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget stockId -> do + core <- readIORef coreRef + case core of + Nothing -> do + image <- imageNewFromStock stockId IconSizeLargeToolbar + widgetSetName image (getParameter paraName parameters) + containerAdd widget image + writeIORef coreRef (Just (image,stockId)) + Just (image,stockId2) -> imageSetFromStock image stockId IconSizeLargeToolbar) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just (_,stockId3) -> return (Just stockId3)) + parameters + notifier +-- +-- | Editor for a string in the form of a text entry +-- +stringEditor :: (String -> Bool) -> Editor String +stringEditor validation parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget string -> do + core <- readIORef coreRef + case core of + Nothing -> do + entry <- entryNew + widgetSetName entry (getParameter paraName parameters) + mapM_ (activateEvent (castToWidget entry) notifier Nothing) + [FocusOut,FocusIn,AfterKeyRelease] + 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 + if validation r + then return (Just r) + else return Nothing) + parameters + notifier + +-- +-- | Editor for a multiline string in the form of a multiline text entry +-- +multilineStringEditor :: Editor String +multilineStringEditor parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget string -> do + core <- readIORef coreRef + case core of + Nothing -> do + aTextView <- textViewNew + widgetSetName aTextView (getParameter paraName parameters) + aScrolledWindow <- scrolledWindowNew Nothing Nothing + scrolledWindowSetPolicy aScrolledWindow PolicyAutomatic PolicyAutomatic + containerAdd aScrolledWindow aTextView + containerAdd widget aScrolledWindow + mapM_ (activateEvent (castToWidget aTextView) notifier Nothing) + [ButtonRelease,FocusOut,FocusIn] + 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)) + parameters + notifier + +-- +-- | Editor for an integer in the form of a spin entry +-- +intEditor :: (Double,Double,Double) -> Editor Int +intEditor (min, max, step) parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget v -> do + core <- readIORef coreRef + case core of + Nothing -> do + spin <- spinButtonNewWithRange min max step + widgetSetName spin (getParameter paraName parameters) + mapM_ (activateEvent (castToWidget spin) notifier Nothing) + [FocusOut,FocusIn] + 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))) + parameters + notifier + +-- +-- | 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 notifier = do + (wid,inj,ext) <- stringEditor (const True) parameters notifier + let ginj = inj . show + let gext = do + s <- ext + case s of + Nothing -> return Nothing + Just s -> catch (liftM Just (readIO s)) + (\e -> do + sysMessage Normal $"Generic editor no parse for " ++ s ++ " " ++ show e + return Nothing) + return (wid,ginj,gext) + +-- +-- | Editor for a boolean value in the form of a check button +-- +buttonEditor :: Editor () +buttonEditor parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget _ -> do + core <- readIORef coreRef + case core of + Nothing -> do + button <- buttonNewWithLabel (getParameter paraName parameters) + widgetSetName button (getParameter paraName parameters) + containerAdd widget button + mapM_ (activateEvent (castToWidget button) notifier Nothing) + [Clicked,FocusIn] + writeIORef coreRef (Just button) + Just button -> return ()) + (return (Just ())) + parameters + notifier + +-- +-- | Editor for the selection of some element from a static list of elements in the +-- | form of a combo box + +comboSelectionEditor :: (Show beta, Eq beta) => [beta] -> Editor beta +comboSelectionEditor list parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget obj -> do + core <- readIORef coreRef + case core of + Nothing -> do + (combo,ls) <- New.comboBoxNewText show list + widgetSetName combo (getParameter paraName parameters) + mapM_ (activateEvent (castToWidget combo) notifier Nothing) + [FocusOut,FocusIn] + 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 + (-1) -> return Nothing + otherwise -> return (Just (list !! ind))) + parameters + notifier + +-- +-- | Editor for the selection of some elements from a list of elements in the +-- | form of a list box +multiselectionEditor :: (Show beta, Eq beta) => Editor [beta] +multiselectionEditor parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget objs -> do + core <- readIORef coreRef + case core of + Nothing -> do + listStore <- New.listStoreNew ([]:: [alpha]) + listView <- New.treeViewNewWithModel listStore + widgetSetName listView (getParameter paraName parameters) + mapM_ (activateEvent (castToWidget listView) notifier Nothing) + [FocusOut,FocusIn] + 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)) + parameters + notifier + +-- +-- | Editor for the selection of some elements from a static list of elements in the +-- | form of a list box + +staticListEditor :: (Show beta, Eq beta) => [beta] -> Editor [beta] +staticListEditor list parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget objs -> do + core <- readIORef coreRef + case core of + Nothing -> do + listStore <- New.listStoreNew ([]:: [alpha]) + listView <- New.treeViewNewWithModel listStore + widgetSetName listView (getParameter paraName parameters) + mapM_ (activateEvent (castToWidget listView) notifier Nothing) + [FocusOut,FocusIn] + sel <- New.treeViewGetSelection listView + New.treeSelectionSetMode sel + (case getParameter paraMultiSel parameters of + True -> SelectionMultiple + False -> SelectionSingle) + 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 + let minSize = getParameter paraMinSize parameters + uncurry (widgetSetSizeRequest listView) minSize + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw listView + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + containerAdd widget sw + 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))) + parameters + notifier + +-- +-- | 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 notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget filePath -> do + core <- readIORef coreRef + case core of + Nothing -> do + button <- buttonNewWithLabel buttonName + widgetSetName button $ getParameter paraName parameters ++ "-button" + mapM_ (activateEvent (castToWidget button) notifier Nothing) + [FocusOut,FocusIn,Clicked] + entry <- entryNew + widgetSetName entry $ getParameter paraName parameters ++ "-entry" + set entry [ entryEditable := False ] + mapM_ (activateEvent (castToWidget entry) notifier Nothing) + [FocusOut,FocusIn] + registerEvent 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) + 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)) + parameters + notifier + 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 (e{gtkReturn=True}) + Just fn -> do + let relative = case mbFilePath of + Nothing -> fn + Just rel -> makeRelative rel fn + entrySetText entry relative +-- triggerEvent notifier SelectionChanged... + return (e{gtkReturn=True}) + +-- +-- | Editor for a font selection +-- +fontEditor :: Editor (Maybe String) +fontEditor parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget mbValue -> do + core <- readIORef coreRef + case core of + Nothing -> do + fs <- fontButtonNew + widgetSetName fs $ getParameter paraName parameters + mapM_ (activateEvent (castToWidget fs) notifier Nothing) + [FocusOut,FocusIn,Clicked] + 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))) + parameters + notifier + +-- +-- | 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 notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget val -> do + core <- readIORef coreRef + case core of + Nothing -> do + button <- buttonNewWithLabel (getParameter paraName parameters) + widgetSetName button $ getParameter paraName parameters + containerAdd widget button + mapM_ (activateEvent (castToWidget button) notifier Nothing) + [FocusOut,FocusIn,Clicked] + registerEvent 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)) + (paraName <<<- ParaName "" $ parameters) + notifier + where + buttonHandler coreRef e = do + core <- readIORef coreRef + case core of + Nothing -> error "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 (e{gtkReturn=True}) + Just nval -> do + writeIORef coreRef (Just (b, nval)) + return (e{gtkReturn=True}) + +okCancelFields :: FieldDescription () +okCancelFields = HFD emptyParams [ + mkField + (paraStockId <<<- ParaStockId stockOk + $ paraName <<<- ParaName "Ok" + $ emptyParams) + (const ()) + (\ a b -> b) + clickEditor + , mkField + (paraStockId <<<- ParaStockId stockCancel + $ paraName <<<- ParaName "Cancel" + $ emptyParams) + (const ()) + (\ _ b -> b) + clickEditor] + diff --git a/src/Graphics/UI/Frame/Panes.hs b/src/Graphics/UI/Frame/Panes.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Frame/Panes.hs @@ -0,0 +1,137 @@ +{-# OPTIONS_GHC + -XExistentialQuantification + -XMultiParamTypeClasses + -XFunctionalDependencies #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Core.Panes +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | The basic definitions for all panes +-- +------------------------------------------------------------------------------- + +module Graphics.UI.Frame.Panes ( + +-- * Panes and pane layout + PaneMonad(..) +, Pane(..) +, IDEPane(..) +, RecoverablePane(..) +, PaneDirection(..) +, PanePath +, PaneLayout(..) +, PaneName +, Connection(..) +, Connections +, StandardPath +, signalDisconnectAll +) where + +import Graphics.UI.Gtk hiding (get) +import System.Glib.GObject +import System.Glib.Signals +import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Typeable +import Control.Monad.Trans + +-- --------------------------------------------------------------------- +-- 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) + +-- +-- | All kinds of panes are instances of pane +-- + +class (Typeable alpha, PaneMonad beta) => Pane alpha beta | alpha -> beta 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 -> beta () + makeActive _ = return () + close :: alpha -> beta () + +class (Pane alpha delta, Read beta, Show beta, Typeable beta, PaneMonad delta) + => RecoverablePane alpha beta delta | beta -> alpha, alpha -> beta where + saveState :: alpha -> delta (Maybe beta) + recoverState :: PanePath -> beta -> delta () + +type PaneName = String + +data IDEPane delta = forall alpha beta. (RecoverablePane alpha beta delta) => PaneC alpha + +instance Eq (IDEPane delta) where + (== ) (PaneC x) (PaneC y) = paneName x == paneName y + +instance Ord (IDEPane delta) where + (<=) (PaneC x) (PaneC y) = paneName x <= paneName y + +instance Show (IDEPane delta) where + show (PaneC x) = "Pane " ++ paneName x + +type StandardPath = PanePath + + +class MonadIO delta => PaneMonad delta where + getWindowSt :: delta Window + getUIManagerSt :: delta UIManager + + getPanesSt :: delta (Map PaneName (IDEPane delta)) + setPanesSt :: Map PaneName (IDEPane delta) -> delta () + + getPaneMapSt :: delta (Map PaneName (PanePath, Connections)) + setPaneMapSt :: Map PaneName (PanePath, Connections) -> delta () + + getActivePaneSt :: delta (Maybe (PaneName, Connections)) + setActivePaneSt :: Maybe (PaneName, Connections) -> delta () + + getLayoutSt :: delta PaneLayout + setLayoutSt :: PaneLayout -> delta () + + runInIO :: forall beta. (beta -> delta()) -> delta (beta -> IO ()) + + +-- +-- | Signal handlers for the different pane types +-- +data Connection = forall alpha . GObjectClass alpha => ConnectC (ConnectId alpha) + +type Connections = [Connection] + +signalDisconnectAll :: Connections -> IO () +signalDisconnectAll = mapM_ (\ (ConnectC s) -> signalDisconnect s) + + + diff --git a/src/Graphics/UI/Frame/ViewFrame.hs b/src/Graphics/UI/Frame/ViewFrame.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Frame/ViewFrame.hs @@ -0,0 +1,656 @@ +{-# OPTIONS_GHC #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Core.ViewFrame +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- +-- | Splittable panes containing notebooks with any widgets +-- +--------------------------------------------------------------------------------- + +module Graphics.UI.Frame.ViewFrame ( + removePaneAdmin +, addPaneAdmin +, notebookInsertOrdered + +-- * Convenience methods for accesing Pane state +, posTypeToPaneDirection +, paneDirectionToPosType +, paneFromName +, mbPaneFromName +, guiPropertiesFromName + +-- * View Actions +, viewMove +, viewSplitHorizontal +, viewSplitVertical +, viewSplit +, viewSplit' +, handleNotebookSwitch +, viewCollapse +, viewCollapse' +, viewTabsPos +, viewSwitchTabs + +-- * View Queries +, getStandardPanePath +, getActivePanePath +, getActivePanePathOrStandard +, figureOutPaneName +, getNotebook +, getPaned +, getActiveNotebook +, getPane +, getPanes + +-- * View Actions +, bringPaneToFront +, newNotebook + +-- * Accessing GUI elements +, widgetFromPath +, getUIAction +, widgetGet + + +) 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 +#if __GLASGOW_HASKELL__ >= 609 +import Control.OldException(evaluate,catch) +#else +import Control.Exception(evaluate,catch) +#endif +import Prelude hiding(catch) +import Data.Unique +import Data.Typeable + +import Graphics.UI.Frame.Panes +import Graphics.UI.Editor.Parameters + +removePaneAdmin :: Pane alpha beta => alpha -> beta () +removePaneAdmin pane = do + panes' <- getPanesSt + paneMap' <- getPaneMapSt + setPanesSt (Map.delete (paneName pane) panes') + setPaneMapSt (Map.delete (paneName pane) paneMap') + +addPaneAdmin :: RecoverablePane alpha beta delta => alpha -> Connections -> PanePath -> delta () +addPaneAdmin pane conn pp = do + panes' <- getPanesSt + paneMap' <- getPaneMapSt + unique <- liftIO newUnique + liftIO $ widgetSetName (getTopWidget pane) (show (hashUnique unique)) + setPaneMapSt (Map.insert (paneName pane) (pp, conn) paneMap') + setPanesSt (Map.insert (paneName pane) (PaneC pane) panes') + +getPane :: RecoverablePane alpha beta delta => delta (Maybe alpha) +getPane = do + selectedPanes <- getPanes + if null selectedPanes || length selectedPanes > 1 + then return Nothing + else (return (Just $head selectedPanes)) + +getPanes :: RecoverablePane alpha beta delta => delta ([alpha]) +getPanes = do + panes' <- getPanesSt + return (catMaybes + $ map (\(PaneC p) -> cast p) + $ Map.elems panes') + +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 + -> Maybe Label + -> IO () +notebookInsertOrdered nb widget label mbTabLabel = do + menuLabel <- labelNew (Just label) + tabLabel <- case mbTabLabel of + Nothing -> labelNew (Just label) + Just l -> return l + numPages <- notebookGetNPages nb + mbWidgets <- mapM (notebookGetNthPage nb) [0 .. (numPages-1)] + widgets <- catch (evaluate (map fromJust mbWidgets)) + (\e -> error "ViewFrame.notebookInsertOrdered: no widget") + mbLabels <- mapM (notebookGetTabLabelText nb) widgets + labels <- catch (evaluate (map fromJust mbLabels)) + (\e -> error "ViewFrame.notebookInsertOrdered: no label") + let pos = case findIndex (\s -> s > label) labels of + Just i -> i + Nothing -> -1 + realPos <- notebookInsertPageMenu nb widget tabLabel menuLabel pos + notebookSetCurrentPage nb realPos + + + +-- | Constructs a unique pane name, which is an index and a string +figureOutPaneName :: Map String (IDEPane alpha) -> String -> Int -> (Int,String) +figureOutPaneName bufs bn ind = + let ind = foldr (\(PaneC 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 :: PaneMonad alpha => PaneName -> alpha (IDEPane alpha) +paneFromName pn = do + mbPane <- mbPaneFromName pn + case mbPane of + Just p -> return p + Nothing -> error $"Cant't find pane from unique name " ++ pn + +mbPaneFromName :: PaneMonad alpha => PaneName -> alpha (Maybe (IDEPane alpha)) +mbPaneFromName pn = do + panes <- getPanesSt + return (Map.lookup pn panes) + +-- | +guiPropertiesFromName :: PaneMonad alpha => PaneName -> alpha (PanePath, Connections) +guiPropertiesFromName pn = do + paneMap <- getPaneMapSt + case Map.lookup pn paneMap of + Just it -> return it + otherwise -> error $"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 + +-- +-- | Toggle the tabs of the current notebook +-- +viewSwitchTabs :: PaneMonad alpha => alpha () +viewSwitchTabs = do + mbNb <- getActiveNotebook + case mbNb of + Nothing -> return () + Just nb -> liftIO $do + b <- notebookGetShowTabs nb + notebookSetShowTabs nb (not b) + +-- +-- | Sets the tab position in the current notebook +-- +viewTabsPos :: PaneMonad alpha => PositionType -> alpha () +viewTabsPos pos = do + mbNb <- getActiveNotebook + case mbNb of + Nothing -> return () + Just nb -> liftIO $notebookSetTabPos nb pos + +-- +-- | Split the currently active pane in horizontal direction +-- +viewSplitHorizontal :: PaneMonad alpha => alpha () +viewSplitHorizontal = viewSplit Horizontal + +-- +-- | Split the currently active pane in vertical direction +-- +viewSplitVertical :: PaneMonad alpha => alpha () +viewSplitVertical = viewSplit Vertical + +-- +-- | The active view can be split in two (horizontal or vertical) +-- +viewSplit :: PaneMonad alpha => Direction -> alpha () +viewSplit dir = do + mbPanePath <- getActivePanePath + case mbPanePath of + Nothing -> return () + Just panePath -> viewSplit' panePath dir + +viewSplit' :: PaneMonad alpha => PanePath -> Direction -> alpha () +viewSplit' panePath dir = do + activeNotebook <- getNotebook panePath + + mbPD <- do + mbParent <- liftIO $ widgetGetParent activeNotebook + case mbParent of + Nothing -> return Nothing + Just parent -> do + (nb,paneDir) <- liftIO $ 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 (nb,paneDir) + handleFunc <- runInIO (handleNotebookSwitch nb) + liftIO $ afterSwitchPage nb handleFunc + return (Just (paneDir,dir)) + case mbPD of + Just (paneDir,dir) -> do + let toPane = panePath ++ [paneDir] + adjustPane panePath toPane + adjustLayoutForSplit dir panePath + Nothing -> return () + +handleNotebookSwitch :: PaneMonad beta => Notebook -> Int -> beta () +handleNotebookSwitch nb index = do + mbW <- liftIO $ notebookGetNthPage nb index + case mbW of + Nothing -> error "ViewFrame/handleNotebookSwitch: Can't find widget" + Just w -> do + mbPane <- findPaneFor w + case mbPane of + Nothing -> return () + Just (PaneC p) -> makeActive p + where + findPaneFor :: PaneMonad beta => Widget -> beta (Maybe (IDEPane beta)) + findPaneFor w = do + panes' <- getPanesSt + n1 <- liftIO $ widgetGetName w + foldM (\r (PaneC p) -> do + n2 <- liftIO $ widgetGetName (getTopWidget p) + return (if n1 == n2 then (Just (PaneC p)) else r)) + Nothing (Map.elems panes') + +-- +-- | Two notebooks can be collapsed to one +-- +viewCollapse :: PaneMonad alpha => alpha () +viewCollapse = do + mbPanePath <- getActivePanePath + case mbPanePath of + Nothing -> return () + Just panePath -> do + viewCollapse' panePath + +viewCollapse' :: PaneMonad alpha => PanePath -> alpha () +viewCollapse' panePath = do + layout1 <- getLayoutSt + let newPanePath = reverse $tail $reverse panePath + let mbOtherSidePath = otherSide panePath + case mbOtherSidePath of + Nothing -> return () + 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 <- getPaneMapSt + activeNotebook <- getNotebook panePath + let paneNamesToMove = map (\(w,(p,_)) -> w) + $filter (\(w,(p,_)) -> p == otherSidePath) + $Map.toList paneMap + panesToMove <- mapM paneFromName paneNamesToMove + mapM_ (\(PaneC p) -> move panePath p) panesToMove + liftIO $ do + mbParent <- widgetGetParent activeNotebook + case mbParent of + Nothing -> error "collapse: no parent" + Just parent -> do + mbGrandparent <- widgetGetParent parent + case mbGrandparent of + Nothing -> error "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 :: Pane alpha beta => PanePath -> alpha -> beta () +move toPane idew = do + paneMap <- getPaneMapSt + let child = getTopWidget idew + (fromPane,cid) <- guiPropertiesFromName (paneName idew) + fromNB <- getNotebook fromPane + toNB <- getNotebook toPane + liftIO $ do + mbNum <- notebookPageNum fromNB child + case mbNum of + Nothing -> return () + Just pn -> do + mbText <- notebookGetTabLabelText fromNB child + mbLabel <- notebookGetTabLabel fromNB child + case (mbText,mbLabel) of + (Just text, Just label) -> do + notebookRemovePage fromNB pn + notebookInsertOrdered toNB child text (Just (castToLabel label)) + _ -> return () + let paneMap1 = Map.delete (paneName idew) paneMap + setPaneMapSt $ Map.insert (paneName idew) (toPane,cid) paneMap1 + +-- +-- | Moves the activePane in the given direction, if possible +-- | If their are many possibilities choose the leftmost and topmost +-- +viewMove :: PaneMonad beta => PaneDirection -> beta () +viewMove direction = do + mbPane <- getActivePaneSt + case mbPane of + Nothing -> do + return () + Just (paneName,_) -> do + (PaneC pane) <- paneFromName paneName + mbPanePath <- getActivePanePath + case mbPanePath of + Nothing -> do + return () + Just panePath -> do + layout <- getLayoutSt + case findMoveTarget panePath layout direction of + Nothing -> do + 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 beta => 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 valid panePath from a standard path. +-- +getStandardPanePath :: StandardPath -> PaneLayout -> PanePath +getStandardPanePath sp pl = reverse $ getStandard' sp pl [] + where + getStandard' _ (TerminalP _ _) p = p + getStandard' (LeftP:sp) (VerticalP l r _) p = getStandard' sp l (LeftP:p) + getStandard' (RightP:sp) (VerticalP l r _) p = getStandard' sp r (RightP:p) + getStandard' (TopP:sp) (HorizontalP t b _) p = getStandard' sp t (TopP:p) + getStandard' (BottomP:sp) (HorizontalP t b _) p = getStandard' sp b (BottomP:p) + -- if no match get leftmost topmost + getStandard' _ (VerticalP l r _) p = getStandard' [] l (LeftP:p) + getStandard' _ (HorizontalP t b _) p = getStandard' [] t (TopP: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 :: PaneMonad alpha => PanePath -> (Widget -> beta) -> alpha beta +getNotebookOrPaned p cf = (widgetGet $["topBox","root"] ++ map paneDirectionToWidgetName p) cf + +-- +-- | Get the notebook widget for the given pane path +-- +getNotebook :: PaneMonad alpha => PanePath -> alpha Notebook +getNotebook p = getNotebookOrPaned p castToNotebook + +-- +-- | Get the (gtk) Paned widget for a given path +-- +getPaned :: PaneMonad alpha => PanePath -> alpha Paned +getPaned p = getNotebookOrPaned p castToPaned + +-- +-- | Get the path to the active pane +-- +getActivePanePath :: PaneMonad alpha => alpha (Maybe PanePath) +getActivePanePath = do + mbPane <- getActivePaneSt + case mbPane of + Nothing -> return Nothing + Just (paneName,_) -> do + (pp,_) <- guiPropertiesFromName paneName + return (Just (pp)) + +getActivePanePathOrStandard :: PaneMonad alpha => StandardPath -> alpha (PanePath) +getActivePanePathOrStandard sp = do + mbApp <- getActivePanePath + case mbApp of + Just app -> return app + Nothing -> do + layout <- getLayoutSt + return (getStandardPanePath sp layout) + + +-- +-- | Get the active notebook +-- +getActiveNotebook :: PaneMonad alpha => alpha (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 :: PaneMonad alpha => PanePath -> PanePath -> alpha () +adjustPane fromPane toPane = do + paneMap <- getPaneMapSt + let newMap = Map.map (\(pp,other) -> do + if pp == fromPane + then (toPane,other) + else (pp,other)) paneMap + setPaneMapSt newMap + +-- +-- | Changes the layout for a split +-- +adjustLayoutForSplit :: PaneMonad alpha => Direction -> PanePath -> alpha () +adjustLayoutForSplit dir path = do + layout <- getLayoutSt + let newTerm = case dir of + Horizontal -> HorizontalP (TerminalP Nothing 0) (TerminalP Nothing 0) 0 + Vertical -> VerticalP (TerminalP Nothing 0) (TerminalP Nothing 0) 0 + setLayoutSt $ adjust path layout newTerm + +-- +-- | Changes the layout for a collapse + +-- +adjustLayoutForCollapse :: PaneMonad alpha => PanePath -> alpha () +adjustLayoutForCollapse path = do + layout <- getLayoutSt + setLayoutSt $ adjust path layout (TerminalP Nothing 0) + +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 = error $"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 -> error $"Cant't find widget path " ++ show (h:t) + Just ind -> widgetFromPath (children !! ind) t + + +widgetGet :: PaneMonad alpha => [String] -> (Widget -> b) -> alpha (b) +widgetGet strL cf = do + w <- getWindowSt + r <- liftIO $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 :: PaneMonad alpha => String -> (Action -> a) -> alpha (a) +getUIAction str f = do + uiManager <- getUIManagerSt + liftIO $ do + findAction <- uiManagerGetAction uiManager str + case findAction of + Just act -> return (f act) + Nothing -> error $"getUIAction can't find action " ++ str diff --git a/src/IDE/BuildInfoEditor.hs b/src/IDE/BuildInfoEditor.hs deleted file mode 100644 --- a/src/IDE/BuildInfoEditor.hs +++ /dev/null @@ -1,315 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} --- --- | Module for editing of cabal build infos --- - -module IDE.BuildInfoEditor ( - editBuildInfo -- Maybe FilePath -> [String] -> BuildInfo -> String -> IO (Maybe BuildInfo) -, BuildEditorFactory(..) -, BuildEditorFactoryI(..) -) where - -import Graphics.UI.Gtk -import qualified Graphics.UI.Gtk.ModelView as New(cellText) -import Control.Monad.Reader -import Distribution.PackageDescription -import Data.IORef -import Data.List - -import IDE.Core.State -import IDE.SpecialEditors -import IDE.Framework.ViewFrame -import IDE.Framework.EditorBasics -import IDE.Framework.MakeEditor -import IDE.Framework.SimpleEditors -import IDE.Framework.CompositeEditors -import IDE.Framework.Parameters - -class IDEEditor alpha => BuildEditorFactory alpha where - buildInfoEditor :: alpha -> Maybe FilePath -> [String] -> Editor BuildInfo - libraryEditor :: alpha -> Maybe FilePath -> [String] -> Editor Library - executableEditor :: alpha -> Maybe FilePath -> [String] -> Editor Executable - executablesEditor :: alpha -> Maybe FilePath -> [String] -> Editor [Executable] - -data BuildEditorFactoryI = BuildEditorFactoryI - deriving (Eq,Ord,Show) - -instance IDEObject BuildEditorFactoryI -instance IDEEditor BuildEditorFactoryI -instance BuildEditorFactory BuildEditorFactoryI where - buildInfoEditor factory mbFp list = buildInfoEditor' mbFp list - libraryEditor factory mbFp list = libraryEditor' mbFp list - executableEditor factory mbFp list = executableEditor' mbFp list - executablesEditor factory mbFp list = executablesEditor' mbFp list - --- ------------------------------------------------------------ --- * Build Infos --- ------------------------------------------------------------ - -buildInfoEditor' :: Maybe FilePath -> [String] -> Editor BuildInfo -buildInfoEditor' fp modules p = do - (wid,inj,ext,notif) <- otherEditor (editBuildInfo fp modules) p - box <- vBoxNew False 1 - textView <- textViewNew - widgetSetSizeRequest textView (-1) 300 - containerAdd box wid - containerAdd box textView - buffer <- textViewGetBuffer textView - let binj bi = do - inj bi - textBufferSetText buffer $showHookedBuildInfo (Just bi,[]) - notif FocusIn $Left (changedHandler buffer ext) - return (castToWidget box,binj,ext,notif) - where - changedHandler buffer ext _ = do - mbv <- ext - case mbv of - Just v -> textBufferSetText buffer $showHookedBuildInfo (Just v,[]) - Nothing -> return () - return True - -libraryEditor' :: Maybe FilePath -> [String] -> Editor Library -libraryEditor' fp modules para = do - (wid,inj,ext,notif) <- - pairEditor - (modulesEditor modules, paraName <<<- ParaName "Exposed Modules" $para) - (buildInfoEditor' fp modules, paraName <<<- ParaName "Build Info" $ para) - (paraDirection <<<- ParaDirection Vertical $ emptyParams) - let pinj (Library em bi) = inj (em,bi) - let pext = do - mbp <- ext - case mbp of - Nothing -> return Nothing - Just (em,bi) -> return (Just $Library em bi) - return (wid,pinj,pext,notif) - -modulesEditor :: [String] -> Editor [String] -modulesEditor modules = staticMultiselectionEditor modules - -moduleEditor :: [String] -> Editor String -moduleEditor modules = staticSelectionEditor modules - - -executableEditor' :: Maybe FilePath -> [String] -> Editor Executable -executableEditor' fp modules para = do - (wid,inj,ext,notif) <- pairEditor - (pairEditor - (stringEditor, paraName <<<- ParaName "Executable Name" $ emptyParams) - (fileEditor fp FileChooserActionOpen "Select File", - paraName <<<- ParaName "Main Module" $ emptyParams), - (paraDirection <<<- ParaDirection Vertical $ emptyParams)) - (buildInfoEditor' fp modules, paraName <<<- ParaName "Build Info" $ emptyParams) - (paraDirection <<<- ParaDirection Vertical $ para) - let pinj (Executable s f bi) = inj ((s,f),bi) - let pext = do - mbp <- ext - case mbp of - Nothing -> return Nothing - Just ((s,f),bi) -> return (Just $Executable s f bi) - return (wid,pinj,pext,notif) - -executablesEditor' :: Maybe FilePath -> [String] -> Editor [Executable] -executablesEditor' fp modules p = - multisetEditor - (ColumnDescr False [("Executable Name",\(Executable exeName _ _) -> [New.cellText := exeName]) - ,("Module Path",\(Executable _ mp _) -> [New.cellText := mp])]) - (executableEditor' fp modules ,emptyParams) - (paraShadow <<<- ParaShadow ShadowIn $ p) - -buildInfoD :: Maybe FilePath -> [String] -> [(String,[FieldDescription BuildInfo])] -buildInfoD fp modules = [ - ("Description", [ - mkField - (paraName <<<- ParaName "Component is buildable here" $ emptyParams) - buildable - (\ a b -> b{buildable = a}) - boolEditor - , mkField - (paraName <<<- ParaName "Non-exposed or non-main modules" - $ paraSynopsis <<<- ParaSynopsis ("A list of modules used by the component but " - ++ "not exposed to users.") - $ paraShadow <<<- ParaShadow ShadowIn - $ paraDirection <<<- ParaDirection Vertical - $ emptyParams) - otherModules - (\ a b -> b{otherModules = a}) - (modulesEditor modules) - , mkField - (paraName <<<- ParaName - "Where to look for the haskell module hierarchy" - $ paraSynopsis <<<- ParaSynopsis - "Root directories for the module hierarchy." - $ paraShadow <<<- ParaShadow ShadowIn - $ paraDirection <<<- ParaDirection Vertical - $ emptyParams) - hsSourceDirs - (\ a b -> b{hsSourceDirs = a}) - (filesEditor fp FileChooserActionSelectFolder "Select folder") - ]), - ("Extensions",[ - mkField - (paraName <<<- ParaName "Extensions" - $ paraSynopsis <<<- ParaSynopsis - "A list of Haskell extensions used by every module." - $ emptyParams) - extensions - (\ a b -> b{extensions = a}) - extensionsEditor - ]), - ("Options",[ - mkField - (paraName <<<- ParaName "Options for haskell compilers" - $ paraDirection <<<- ParaDirection Vertical - $ emptyParams) - options - (\ a b -> b{options = a}) - (multisetEditor - (ColumnDescr True [("Compiler Flavor",\(cv,_) -> [New.cellText := show cv]) - ,("Options",\(_,op) -> [New.cellText := show op])]) - ((pairEditor - (compilerFlavorEditor,emptyParams) - (stringsEditor,emptyParams)), - (paraDirection <<<- ParaDirection Vertical - $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams))) - , mkField - (paraName <<<- ParaName "Additional options for GHC when built with profiling" - $ paraDirection <<<- ParaDirection Vertical - $ emptyParams) - ghcProfOptions - (\ a b -> b{ghcProfOptions = a}) - stringsEditor - , mkField - (paraName <<<- ParaName "Options for C compiler" - $ paraDirection <<<- ParaDirection Vertical - $ emptyParams) - ccOptions - (\ a b -> b{ccOptions = a}) - stringsEditor - , mkField - (paraName <<<- ParaName "Options for linker" - $ paraDirection <<<- ParaDirection Vertical - $ emptyParams) - ldOptions - (\ a b -> b{ldOptions = a}) - stringsEditor - ]), - ("C",[ - mkField - (paraName <<<- ParaName "A list of header files already installed on the system" - $ paraDirection <<<- ParaDirection Vertical $ emptyParams) - includes - (\ a b -> b{includes = a}) - stringsEditor - , mkField - (paraName <<<- ParaName "A list of header files from this package" - $ paraDirection <<<- ParaDirection Vertical $ emptyParams) - installIncludes - (\ a b -> b{installIncludes = a}) - (filesEditor fp FileChooserActionOpen "Select File") - , mkField - (paraName <<<- ParaName "A list of directories to search for header files" - $ paraDirection <<<- ParaDirection Vertical $ emptyParams) - includeDirs - (\ a b -> b{includeDirs = a}) - (filesEditor fp FileChooserActionSelectFolder "Select Folder") - , mkField - (paraName <<<- ParaName - "A list of C source files to be compiled,linked with the Haskell files." - $ paraDirection <<<- ParaDirection Vertical $ emptyParams) - cSources - (\ a b -> b{cSources = a}) - (filesEditor fp FileChooserActionOpen "Select file") - , mkField - (paraName <<<- ParaName "A list of extra libraries to link with" - $ paraDirection <<<- ParaDirection Vertical $ emptyParams) - extraLibs - (\ a b -> b{extraLibs = a}) - stringsEditor - , mkField - (paraName <<<- ParaName "A list of directories to search for libraries." - $ paraDirection <<<- ParaDirection Vertical $ emptyParams) - extraLibDirs - (\ a b -> b{extraLibDirs = a}) - (filesEditor fp FileChooserActionSelectFolder "Select Folder") - ]), - ("Mac OS X",[ - mkField - (paraName <<<- ParaName "Support frameworks for Mac OS X" - $ paraDirection <<<- ParaDirection Vertical $ emptyParams) - cSources - (\ a b -> b{cSources = a}) - stringsEditor - ])] - - -editBuildInfo :: Maybe FilePath -> [String] -> BuildInfo -> String -> IO (Maybe BuildInfo) -editBuildInfo fp modules buildInfo contextStr = do - res <- editBuildInfo' buildInfo contextStr (buildInfoD fp modules) - return res - -editBuildInfo' :: BuildInfo -> String -> [(String,[FieldDescription BuildInfo])] -> IO (Maybe BuildInfo) -editBuildInfo' buildInfo contextStr buildInfoD = do - resRef <- newIORef Nothing - dialog <- windowNew - windowSetModal dialog True - vb <- vBoxNew False 7 - bb <- hButtonBoxNew - ok <- buttonNewFromStock "gtk-ok" - cancel <- buttonNewFromStock "gtk-cancel" - boxPackStart bb ok PackNatural 0 - boxPackStart bb cancel PackNatural 0 - nb <- newNotebook - notebookSetTabPos nb PosTop - res <- mapM - (\ (tabLabel, partBuildInfoD) -> do - resList <- mapM (\ (FD _ editorF) -> editorF buildInfo) partBuildInfoD - let (widgetsP, setInjsP, getExtsP,notifiersP) = unzip4 resList - nbbox <- vBoxNew False 0 - mapM_ (\ w -> boxPackStart nbbox w PackNatural 0) widgetsP - sw <- scrolledWindowNew Nothing Nothing - scrolledWindowAddWithViewport sw nbbox - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - notebookAppendPage nb sw tabLabel - return (widgetsP, setInjsP, getExtsP, notifiersP)) - buildInfoD - let (widgets, setInjs, getExts, notifiers) = - foldl (\ (w,i,e,n) (w2,i2,e2,n2) -> (w ++ w2, i ++ i2, e ++ e2, n ++ n2)) ([],[],[],[]) res - let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of - Just s -> s - Nothing -> "Unnamed") - $concatMap snd buildInfoD - ok `onClicked` (do - mbNewBuildInfo <- extractAndValidate buildInfo getExts fieldNames - case mbNewBuildInfo of - Nothing -> do - sysMessage Normal "Cant't validate build info" - return () - Just newBuildInfo -> do - writeIORef resRef (Just newBuildInfo) - widgetDestroy dialog - mainQuit - return ()) - cancel `onClicked` (do - widgetDestroy dialog - mainQuit - return ()) - dialog `onDelete` (\e -> do - widgetDestroy dialog - mainQuit - return True) - boxPackStart vb nb PackGrow 7 - boxPackEnd vb bb PackNatural 7 - containerAdd dialog vb - widgetSetSizeRequest dialog 500 700 - widgetShowAll dialog - mainGUI - res <- readIORef resRef - return (res) - - - - - - - - diff --git a/src/IDE/CallersPane.hs b/src/IDE/CallersPane.hs deleted file mode 100644 --- a/src/IDE/CallersPane.hs +++ /dev/null @@ -1,219 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- --- Module : IDE.CallersPane --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | The pane of ide where modules are presented in tree form with their --- packages and exports --- -------------------------------------------------------------------------------- - -module IDE.CallersPane ( - calledBy -) where - -import Graphics.UI.Gtk hiding (get) -import Graphics.UI.Gtk.ModelView as New -import Data.Maybe -import Control.Monad.Reader -import qualified Data.Map as Map -import qualified Data.Set as Set -import Data.List -import Distribution.Package - -import IDE.Core.State -import IDE.Framework.ViewFrame - -instance IDEObject IDECallers -instance Pane IDECallers - where - primPaneName _ = "Callers" - getAddedIndex _ = 0 - getTopWidget = castToWidget . scrolledView - paneId b = "*Callers" - makeActive p = do - activatePane p (BufConnections[][] []) - close pane = do - (panePath,_) <- guiPropertiesFromName (paneName pane) - nb <- getNotebook panePath - mbI <- lift $notebookPageNum nb (getTopWidget pane) - case mbI of - Nothing -> lift $ do - sysMessage Normal "notebook page not found: unexpected" - return () - Just i -> do - deactivatePaneIfActive pane - lift $notebookRemovePage nb i - removePaneAdmin pane - --- | We don't recover this pane -instance RecoverablePane IDECallers CallersState where - saveState p = return Nothing - recoverState pp _ = return () - - --- | Open a pane with the callers of this identifier -calledBy :: IdentifierDescr - -> IDEAction -calledBy idDescr = do - mbCurrentInfo <- readIDE currentInfo - case mbCurrentInfo of - Nothing -> return () - Just currentInfo' -> - let symModPair = (identifierID idDescr, modu $ moduleIdID idDescr) - modulesList1 = modulesForCallerFromPackages - (Map.elems $ fst $ fst currentInfo') symModPair - modulesList2 = modulesForCallerFromPackages - (Map.elems $ fst $ snd currentInfo') symModPair - modulesList = nub $ modulesList1 ++ modulesList2 - finalList = zip modulesList (repeat (identifierID idDescr)) - in do callers <- getCallers - lift $ do - New.listStoreClear (callersStore callers) - mapM_ (New.listStoreAppend (callersStore callers)) finalList - bringPaneToFront callers - -modulesForCallerFromPackages :: [PackageDescr] -> (Symbol,ModuleIdentifier) -> [ModuleDescr] -modulesForCallerFromPackages [] _ = [] -modulesForCallerFromPackages (p :rest) (sym,mod) = - (filter (\ md -> case mod `Map.lookup` (usagesMD md) of - Nothing -> False - Just syms -> sym `Set.member` syms) (exposedModulesPD p)) - ++ modulesForCallerFromPackages rest (sym,mod) - -getCallers :: IDEM IDECallers -getCallers = do - mbMod <- getPane CallersCasting - case mbMod of - Nothing -> do - prefs <- readIDE prefs - layout <- readIDE layout - let pp = getStandardPanePath (modulesPanePath prefs) layout - nb <- getNotebook pp - initCallers pp nb - mbMod <- getPane CallersCasting - case mbMod of - Nothing -> throwIDE "Can't init callers" - Just m -> return m - Just m -> return m - -initCallers :: PanePath -> Notebook -> IDEAction -initCallers panePath nb = do - ideR <- ask - panes <- readIDE panes - paneMap <- readIDE paneMap - prefs <- readIDE prefs - currentInfo <- readIDE currentInfo - (buf,cids) <- lift $ do - treeStore <- New.listStoreNew [] - treeView <- New.treeViewNew - New.treeViewSetModel treeView treeStore - - renderer0 <- New.cellRendererPixbufNew - set renderer0 [ cellPixbufStockId := stockYes ] - - renderer <- New.cellRendererTextNew - col <- New.treeViewColumnNew - New.treeViewColumnSetTitle col "Modules" - New.treeViewColumnSetSizing col TreeViewColumnAutosize - New.treeViewColumnSetReorderable col True - New.treeViewAppendColumn treeView col - New.cellLayoutPackStart col renderer0 False - New.cellLayoutPackStart col renderer True - New.cellLayoutSetAttributes col renderer treeStore - $ \row -> [ New.cellText := modu $ moduleIdMD $ fst row] - New.cellLayoutSetAttributes col renderer0 treeStore - $ \row -> [cellPixbufStockId := - if isJust (mbSourcePathMD $ fst row) - then stockJumpTo - else stockYes] - - renderer2 <- New.cellRendererTextNew - col2 <- New.treeViewColumnNew - New.treeViewColumnSetTitle col2 "Packages" - New.treeViewColumnSetSizing col2 TreeViewColumnAutosize - New.treeViewColumnSetReorderable col2 True - New.treeViewAppendColumn treeView col2 - New.cellLayoutPackStart col2 renderer2 True - New.cellLayoutSetAttributes col2 renderer2 treeStore - $ \row -> [ New.cellText := showPackageId $ pack $ moduleIdMD $ fst row] - - New.treeViewSetHeadersVisible treeView True - - sw <- scrolledWindowNew Nothing Nothing - containerAdd sw treeView - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - let modules = IDECallers sw treeView treeStore - notebookInsertOrdered nb sw (paneName modules) - widgetShowAll sw - --- cid1 <- treeView `afterFocusIn` --- (\_ -> do runReaderT (makeActive modules) ideR; return True) --- cid2 <- facetView `afterFocusIn` --- (\_ -> do runReaderT (makeActive modules) ideR; return True) --- treeView `onButtonPress` (treeViewPopup ideR treeStore treeView) --- facetView `onButtonPress` (facetViewPopup ideR facetStore facetView) --- sel <- New.treeViewGetSelection treeView --- sel `New.onSelectionChanged` (fillFacets treeView treeStore facetStore) --- sel2 <- New.treeViewGetSelection facetView --- sel2 `New.onSelectionChanged` (fillInfo facetView facetStore ideR) - - return (modules,[]) - addPaneAdmin buf (BufConnections [] [] []) panePath - lift $widgetGrabFocus (scrolledView buf) - - ---getSelectionTree :: New.TreeView --- -> New.ListStore (String, [(ModuleDescr,PackageDescr)]) --- -> IO (Maybe (String, [(ModuleDescr,PackageDescr)])) ---getSelectionTree treeView listStore = do --- treeSelection <- New.treeViewGetSelection treeView --- paths <- New.treeSelectionGetSelectedRows treeSelection --- case paths of --- [] -> return Nothing --- a:r -> do --- val <- New.listStoreGetValue listStore a --- return (Just val) - ---treeViewPopup :: IDERef --- -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) --- -> New.TreeView --- -> Event --- -> IO (Bool) ---treeViewPopup ideR store treeView (Button _ click _ _ _ _ button _ _) = do --- if button == RightButton --- then do --- theMenu <- menuNew --- item1 <- menuItemNewWithLabel "Edit" --- item1 `onActivateLeaf` do --- sel <- getSelectionTree treeView store --- case sel of --- Just (_,[(m,_)]) -> case mbSourcePathMD m of --- Nothing -> return () --- Just fp -> do --- runReaderT (selectSourceBuf fp) ideR --- return () --- otherwise -> return () --- menuShellAppend theMenu item1 --- menuPopup theMenu Nothing --- widgetShowAll theMenu --- return True --- else if button == LeftButton && click == DoubleClick --- then do sel <- getSelectionTree treeView store --- case sel of --- Just (_,[(m,_)]) -> case mbSourcePathMD m of --- Nothing -> return () --- Just fp -> do --- runReaderT (selectSourceBuf fp) ideR --- return () --- otherwise -> return () --- return True --- else return False ---treeViewPopup _ _ _ _ = throwIDE "treeViewPopup wrong event type" - diff --git a/src/IDE/Core/Exception.hs b/src/IDE/Core/Exception.hs deleted file mode 100644 --- a/src/IDE/Core/Exception.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- --- Module : IDE.Core.Exception --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | A Type for IDE exceptions --- Taken from Haddock example. --- -------------------------------------------------------------------------------- - -module IDE.Core.Exception ( - IDEException -, throwIDE -, sysMessage -, MessageLevel(..) -, handleTopExceptions -) where - -import Data.Typeable -import Control.Exception -import System.IO -import Prelude hiding(catch) -import System.Exit - -import Panic -import Bag -import ErrUtils -import DynFlags - -data IDEException = IDEException String - deriving Typeable - -instance Show IDEException where - show (IDEException str) = str - --- dynamic exceptions doesn't work for me, why ---throwIDE str = throwDyn (IDEException str) -throwIDE str = error str - - -sysMessage :: MessageLevel -> String -> IO () -sysMessage ml str = do - putStrLn str - hFlush stdout - -data MessageLevel = Silent | Normal | High - deriving (Eq,Ord,Show) - - --- --------------------------------------------------------------------- --- Exception handling --- - -handleTopExceptions = - handleNormalExceptions . handleIDEExceptions . handleGhcExceptions - -handleNormalExceptions inner = - catch inner (\exception -> do - hFlush stdout - case exception of - AsyncException StackOverflow -> do - sysMessage Normal "stack overflow: use -g +RTS -K to increase it" - exitFailure - ExitException code -> exitWith code - _other -> do - sysMessage Normal ("ide: internal IDE error: " ++ show exception) - exitFailure - ) - - -handleIDEExceptions inner = - catchDyn inner (\(e::IDEException) -> do - sysMessage Normal $ "ide: " ++ (show e) - hFlush stdout - exitFailure - ) - - -handleGhcExceptions inner = - -- throwIDE messages propagated as exceptions - let inner2 = catchDyn inner (\(dyn::GhcException) -> do - hFlush stdout - case dyn of - PhaseFailed _ code -> exitWith code - Interrupted -> exitFailure - _ -> do - print dyn - exitFailure) - in - -- compilation errors: messages with locations attached - catchDyn inner2 (\dyn -> do - sysMessage Normal "ide: Compilation error(s):" - printBagOfErrors defaultDynFlags (unitBag dyn) - exitFailure - ) diff --git a/src/IDE/Core/Panes.hs b/src/IDE/Core/Panes.hs deleted file mode 100644 --- a/src/IDE/Core/Panes.hs +++ /dev/null @@ -1,370 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- --- Module : IDE.Core.Panes --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | The core state of ide. This module is imported from every other module, --- | and all data structures of the state are declared here, to avoid circular --- | module dependencies. --- -------------------------------------------------------------------------------- - -module IDE.Core.Panes ( --- Casting(..) ---, CastingS(..) - --- * Panes and pane layout - Pane(..) -, CastablePane(..) -, Casting(..) -, IDEPane(..) -, RecoverablePane(..) -, PaneDirection(..) -, PanePath -, PaneLayout(..) -, PaneName -, Connections(..) - -, IDEState(..) -, PaneState(..) -, Recoverable(..) - --- * The pane types -, IDEBuffer(..) -, BufferState(..) -, IDEInfo(..) -, InfoState(..) -, FacetWrapper(..) -, IDEModules(..) -, ModulesState(..) -, IDECallers(..) -, CallersState(..) -, IDEToolbar(..) -, ToolbarState(..) - -, IDEReplace(..) -, ReplaceState(..) - -, IDELog(..) -, LogState(..) -, LogTag(..) - -, IDEFind(..) -, FindState(..) - - - -) where - -import Graphics.UI.Gtk.SourceView -import Graphics.UI.Gtk hiding (get) -import Graphics.UI.Gtk.ModelView as New -import System.Glib.Signals -import Data.Maybe -import System.Time -import GHC.IOBase hiding (BufferState) - -import IDE.Core.Types -import {-# SOURCE #-} IDE.Core.State -import IDE.Framework.EditorBasics --- --------------------------------------------------------------------- --- Panes and pane layout --- - - --- --- | A path to a pane --- -type PanePath = [PaneDirection] - --- --- | The relative direction to a pane from the parent --- -data PaneDirection = TopP | BottomP | LeftP | RightP - deriving (Eq,Show,Read) - --- --- | Description of a window layout --- -data PaneLayout = HorizontalP PaneLayout PaneLayout Int - | VerticalP PaneLayout PaneLayout Int - | TerminalP (Maybe PaneDirection) Int - deriving (Eq,Show,Read) - --- --- | Signal handlers for the different pane types --- -data Connections = BufConnections - [ConnectId SourceView] - [ConnectId TextBuffer] - [ConnectId TextView] --- [ConnectId New.TreeView] - -type PaneName = String - --- --- | Description of the different pane types --- - -class IDEObject alpha => Pane alpha where - paneName :: alpha -> PaneName - paneName b = if getAddedIndex b == 0 - then primPaneName b - else primPaneName b ++ "(" ++ show (getAddedIndex b) ++ ")" - primPaneName :: alpha -> String - getAddedIndex :: alpha -> Int - getAddedIndex _ = 0 - getTopWidget :: alpha -> Widget - paneId :: alpha -> String - makeActive :: alpha -> IDEAction - close :: alpha -> IDEAction - - -class (Pane alpha, Recoverable beta) => RecoverablePane alpha beta | beta -> alpha, alpha -> beta where - saveState :: alpha -> IDEM (Maybe IDEState) - recoverState :: PanePath -> beta -> IDEAction - -class CastablePane alpha where - casting :: alpha -> Casting alpha - downCast :: Casting alpha -> IDEPane -> Maybe alpha - isIt :: Casting alpha -> IDEPane -> Bool - isIt t i = isJust (downCast t i) - -data Casting alpha where - LogCasting :: Casting IDELog - InfoCasting :: Casting IDEInfo - BufferCasting :: Casting IDEBuffer - ModulesCasting :: Casting IDEModules - CallersCasting :: Casting IDECallers - ToolbarCasting :: Casting IDEToolbar - FindCasting :: Casting IDEFind - ReplaceCasting :: Casting IDEReplace - -data IDEPane = forall alpha beta . (CastablePane alpha, RecoverablePane alpha beta) => PaneC alpha - -instance IDEObject IDEPane - -instance Pane IDEPane where - paneName (PaneC a) = paneName a - primPaneName (PaneC a) = primPaneName a - getAddedIndex (PaneC a) = getAddedIndex a - getTopWidget (PaneC a) = getTopWidget a - paneId (PaneC a) = paneId a - makeActive (PaneC a) = makeActive a - close (PaneC a) = close a - -class Recoverable alpha where - toPaneState :: alpha -> PaneState - -data IDEState = forall alpha beta . (RecoverablePane alpha beta, Recoverable beta) => StateC beta - -instance Recoverable IDEState where - toPaneState (StateC a) = toPaneState a - -instance RecoverablePane IDEPane IDEState where - saveState (PaneC p) = saveState p - recoverState pp (StateC s) = recoverState pp s - --- --------------------------------------------------------------------- --- All pane types must be in here ! --- - -data PaneState = BufferSt BufferState - | LogSt LogState - | InfoSt InfoState - | ModulesSt ModulesState - | CallersSt CallersState - | ToolbarSt ToolbarState - | FindSt FindState - | ReplaceSt ReplaceState - deriving(Eq,Ord,Read,Show) - --- --------------------------------------------------------------------- --- Special Panes - The data structures for the panes --- - --- --- | A text editor pane description --- -data IDEBuffer = IDEBuffer { - fileName :: Maybe FilePath -, bufferName :: String -, addedIndex :: Int -, sourceView :: SourceView -, scrolledWindow :: ScrolledWindow -, modTime :: Maybe (ClockTime) -} - - -instance CastablePane IDEBuffer where - casting _ = BufferCasting - downCast _ (PaneC a) - = case casting a of - BufferCasting -> Just a - _ -> Nothing - -data BufferState = BufferState FilePath Int - deriving(Eq,Ord,Read,Show) - -instance Recoverable BufferState where - toPaneState a = BufferSt a - - --- --- | An info pane description --- -data IDEInfo = IDEInfo { - sw :: ScrolledWindow -, currentIDs :: IORef [IdentifierDescr] -, currentInd :: IORef Int -, injectors :: [IdentifierDescr -> IO()] -, extractors :: [IdentifierDescr -> Extractor IdentifierDescr] -, nextB :: Button -, prevB :: Button -, numLabel :: Label -} - -instance CastablePane IDEInfo where - casting _ = InfoCasting - downCast _ (PaneC a) = case casting a of - InfoCasting -> Just a - _ -> Nothing - -data InfoState = InfoState [IdentifierDescr] Int - deriving(Eq,Ord,Read,Show) - -instance Recoverable InfoState where - toPaneState a = InfoSt a - - --- | A modules pane description --- - -data IDEModules = IDEModules { - outer :: VBox -, paned :: HPaned -, treeView :: New.TreeView -, treeStore :: New.TreeStore (String, [(ModuleDescr,PackageDescr)]) -, facetView :: New.TreeView -, facetStore :: New.TreeStore FacetWrapper -, localScopeB :: RadioButton -, packageScopeB :: RadioButton -, worldScopeB :: RadioButton -, blacklistB :: CheckButton -} - -instance CastablePane IDEModules where - casting _ = ModulesCasting - downCast _ (PaneC a) = case casting a of - ModulesCasting -> Just a - _ -> Nothing - -data FacetWrapper = - Itself IdentifierDescr - | ConstructorW Symbol IdentifierDescr - | FieldW Symbol IdentifierDescr - | MethodW Symbol IdentifierDescr - | OrphanedData IdentifierDescr - -data ModulesState = ModulesState Int (Scope,Bool) - (Maybe String, Maybe String) - deriving(Eq,Ord,Read,Show) - -instance Recoverable ModulesState where - toPaneState a = ModulesSt a - - --- | A callers pane description --- - -data IDECallers = IDECallers { - scrolledView :: ScrolledWindow -, treeViewC :: New.TreeView -, callersStore :: New.ListStore (ModuleDescr,Symbol) -} - -instance CastablePane IDECallers where - casting _ = CallersCasting - downCast _ (PaneC a) = case casting a of - CallersCasting -> Just a - _ -> Nothing - -data CallersState = CallersState - deriving(Eq,Ord,Read,Show) - -instance Recoverable CallersState where - toPaneState a = CallersSt a - --- | A Toolbar pane description --- -data IDEToolbar = IDEToolbar { - toolbar :: VBox -} - -instance CastablePane IDEToolbar where - casting _ = ToolbarCasting - downCast _ (PaneC a) = case casting a of - ToolbarCasting -> Just a - _ -> Nothing - -data ToolbarState = ToolbarState - deriving(Eq,Ord,Read,Show) - -instance Recoverable ToolbarState where - toPaneState a = ToolbarSt a - --- | A Control pane for simple text replace --- - -data IDEReplace = IDEReplace { - replaceBox :: VBox ---, replaceExtractor :: Extractor ReplaceState -} - -data ReplaceState = ReplaceState{ - searchFor :: String -, replaceWith :: String -, matchCase :: Bool -, matchEntire :: Bool -, searchBackwards :: Bool} - deriving(Eq,Ord,Read,Show) - --- --- | The Log Viev --- - -data IDELog = IDELog { - textView :: TextView -, scrolledWindowL :: ScrolledWindow} - -data LogState = LogState - deriving(Eq,Ord,Read,Show) - -data LogTag = LogTag | ErrorTag | FrameTag - - --- | A Find pane description --- - -data IDEFind = IDEFind { - findBox :: HBox -, caseSensitive :: ToggleButton -, wrapAround :: ToggleButton -, entireWord :: ToggleButton -, gotoLine :: SpinButton -, findEntry :: Entry -} - -data FindState = FindState - deriving(Eq,Ord,Read,Show) - - - - - diff --git a/src/IDE/Core/State.hs b/src/IDE/Core/State.hs --- a/src/IDE/Core/State.hs +++ b/src/IDE/Core/State.hs @@ -1,11 +1,12 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} +{-# OPTIONS_GHC -XFlexibleContexts -XTypeSynonymInstances -XMultiParamTypeClasses + -XScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Core.State -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL -- --- Maintainer : Juergen Nicklisch-Franken +-- Maintainer : Juergen Nicklisch-Franken -- Stability : experimental -- Portability : portable -- @@ -16,14 +17,13 @@ ------------------------------------------------------------------------------- module IDE.Core.State ( - IDEObject(..) + IDEObject , IDEEditor , IDE(..) , IDERef , IDEM , IDEAction , IDEEvent(..) -, EventSelector(..) -- * Convenience methods for accesing the IDE State , readIDE @@ -32,12 +32,37 @@ , withIDE , getIDE +, reifyIDE +, reflectIDE +, catchIDE + , ideMessage , logMessage -, forceJust +, sysMessage +, MessageLevel(..) + +, withoutRecordingDo +, activatePane +, deactivatePane +, deactivatePaneIfActive + +, getCandyState +, setCandyState +, getForgetSession + +, getSBSpecialKeys +, getSBActivePane +, getSBActivePackage +, getSBErrors +, getStatusbarIO +, getStatusbarLC + +, Session + , module IDE.Core.Types -, module IDE.Core.Panes -, module IDE.Core.Exception +, module Graphics.UI.Frame.Panes +, module Graphics.UI.Frame.ViewFrame +, module IDE.Exception ) where @@ -45,19 +70,30 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.IORef -import Control.Monad.Reader -import GHC (Session) +import Control.Monad.Reader hiding (liftIO) +import qualified Control.Monad.Reader (liftIO) +import Control.Monad.Trans +import HscTypes hiding (liftIO) import Data.Unique +import Control.Exception +import Prelude hiding (catch) import IDE.Core.Types -import IDE.Core.Panes -import IDE.Core.Exception +import Graphics.UI.Frame.Panes +import Graphics.UI.Frame.ViewFrame +import IDE.Exception +import Control.Event +import System.IO +-- this should not be repeated here, why is it necessary? +instance MonadIO Ghc where + liftIO ioA = Ghc $ \_ -> ioA + ideMessage :: MessageLevel -> String -> IDEAction ideMessage level str = do st <- ask triggerEvent st (LogMessage (str ++ "\n") LogTag) - lift $ sysMessage level str + liftIO $ sysMessage level str logMessage :: String -> LogTag -> IDEAction logMessage str tag = do @@ -65,66 +101,15 @@ triggerEvent st (LogMessage (str ++ "\n") tag) return () -data IDEEvent = - CurrentInfo - | ActivePack - | SelectInfo String - | SelectIdent IdentifierDescr - | LogMessage String LogTag - | GetToolbar [Widget] +sysMessage :: MonadIO m => MessageLevel -> String -> m () +sysMessage ml str = liftIO $ do + putStrLn str + hFlush stdout -data EventSelector = - CurrentInfoS - | ActivePackS - | SelectInfoS - | SelectIdentS - | LogMessageS - | GetToolbarS +data MessageLevel = Silent | Normal | High 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 alpha class IDEObject o => IDEEditor o @@ -136,55 +121,133 @@ -- | 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) + window :: Window -- ^ the gtk window +, uiManager :: UIManager -- ^ the gtk uiManager +, panes :: Map PaneName (IDEPane IDEM) -- ^ a map with all panes (subwindows) +, activePane :: Maybe (PaneName,Connections) +, lastActiveBufferPane :: Maybe PaneName +, 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)) +, 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)] +, handlers :: Map String [(Unique, IDEEvent -> IDEM IDEEvent)] -- ^ event handling table +, isShuttingDown :: Bool +, guiHistory :: (Bool,[GUIHistory],Int) +, findbar :: Toolbar +, toolbar :: Maybe Toolbar +, findbarVisible :: Bool +, toolbarVisible :: Bool } --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 +data IDEEvent = + CurrentInfo + | ActivePack + | SelectInfo String + | SelectIdent Descr + | LogMessage String LogTag + | RecordHistory GUIHistory + | Sensitivity [(SensitivityMask,Bool)] + | DescrChoice [Descr] + | SearchMeta String + | LoadSession FilePath + | SaveSession FilePath + -- -- | A mutable reference to the IDE state -- type IDERef = IORef IDE +instance Event IDEEvent String where + getSelector CurrentInfo = "CurrentInfo" + getSelector ActivePack = "ActivePack" + getSelector (LogMessage _ _) = "LogMessage" + getSelector (SelectInfo _) = "SelectInfo" + getSelector (SelectIdent _) = "SelectIdent" + getSelector (RecordHistory _) = "RecordHistory" + getSelector (Sensitivity _) = "Sensitivity" + getSelector (DescrChoice _) = "DescrChoice" + getSelector (SearchMeta _) = "SearchMeta" + getSelector (LoadSession _) = "LoadSession" + getSelector (SaveSession _) = "SaveSession" + +instance EventSource IDERef IDEEvent IDEM String where + + canTriggerEvent o "CurrentInfo" = True + canTriggerEvent o "ActivePack" = True + canTriggerEvent o "LogMessage" = True + canTriggerEvent o "SelectInfo" = True + canTriggerEvent o "SelectIdent" = True + canTriggerEvent o "RecordHistory" = True + canTriggerEvent o "Sensitivity" = True + canTriggerEvent o "DescrChoice" = True + canTriggerEvent o "SearchMeta" = True + canTriggerEvent o "LoadSession" = True + canTriggerEvent o "SaveSession" = True + canTriggerEvent _ _ = False + + getHandlers ideRef = do + ide <- liftIO $ readIORef ideRef + return (handlers ide) + + setHandlers ideRef nh = do + ide <- liftIO $ readIORef ideRef + liftIO $ writeIORef ideRef (ide {handlers= nh}) + + myUnique _ = do + liftIO $ newUnique + +instance EventSelector String + + -- -- | A reader monad for a mutable reference to the IDE state -- -type IDEM = ReaderT (IDERef) IO +type IDEM = ReaderT IDERef Ghc +reifyIDE :: (IDERef -> Session -> IO a) -> IDEM a +reifyIDE f = ask >>= \ideR -> lift $ reifyGhc (f ideR) + +reflectIDE :: IDEM a -> IDERef -> Session -> IO a +reflectIDE c ideR = reflectGhc (runReaderT c ideR) + +catchIDE :: Exception e => IDEM a -> (e -> IO a) -> IDEM a +catchIDE block handler = reifyIDE (\ideR session -> catch (reflectIDE block ideR session) handler) + -- -- | A shorthand for a reader monad for a mutable reference to the IDE state -- which does not return a value -- type IDEAction = IDEM () +instance PaneMonad IDEM where + getWindowSt = readIDE window + getUIManagerSt = readIDE uiManager + getPanesSt = readIDE panes + getPaneMapSt = readIDE paneMap + getActivePaneSt = readIDE activePane + getLayoutSt = readIDE layout + setPanesSt v = modifyIDE_ (\ide -> return ide{panes = v}) + setPaneMapSt v = modifyIDE_ (\ide -> return ide{paneMap = v}) + setActivePaneSt v = modifyIDE_ (\ide -> return ide{activePane = v}) + setLayoutSt v = modifyIDE_ (\ide -> return ide{layout = v}) + + runInIO f = reifyIDE (\ideRef session -> + return (\v -> reflectIDE (f v) ideRef session)) + + + -- --------------------------------------------------------------------- -- Convenience methods for accesing the IDE State -- @@ -193,39 +256,147 @@ readIDE :: (IDE -> beta) -> IDEM beta readIDE f = do e <- ask - lift $ liftM f (readIORef e) + liftIO $ 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' + e' <- liftIO $ (f =<< readIORef e) + liftIO $ 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' + (e',result) <- liftIO (f =<< readIORef e) + liftIO $ writeIORef e e' return result withIDE :: (IDE -> IO alpha) -> IDEM alpha withIDE f = do e <- ask - lift $ f =<< readIORef e + liftIO $ f =<< readIORef e getIDE :: IDEM(IDE) getIDE = do e <- ask - st <- lift $ readIORef e + st <- liftIO $ readIORef e return st +withoutRecordingDo :: IDEAction -> IDEAction +withoutRecordingDo act = do + (b,l,n) <- readIDE guiHistory + if not b then do + modifyIDE_ (\ide -> return ide{guiHistory = (True,l,n)}) + act + (b,l,n) <- readIDE guiHistory + modifyIDE_ (\ide -> return ide{guiHistory = (False,l,n)}) + else act + -- --------------------------------------------------------------------- --- Convenience methods for accesing the IDE State +-- Activating and deactivating Panes. +-- This is here and not in Views because it needs some dependencies +-- (e.g. Events for history) -- -forceJust :: Maybe alpha -> String -> alpha -forceJust mb str = case mb of - Nothing -> throwIDE str - Just it -> it + +activatePane :: Pane alpha IDEM => alpha -> Connections -> IDEAction +activatePane pane conn = do + mbAP <- getActivePaneSt + case mbAP of + Just (pn,_) | pn == paneName pane -> return () + _ -> do + deactivatePaneWithout + sb <- getSBActivePane + liftIO $ statusbarPop sb 1 + liftIO $ statusbarPush sb 1 (paneName pane) + liftIO $ bringPaneToFront pane + setActivePaneSt (Just (paneName pane,conn)) + trigger (Just (paneName pane)) (case mbAP of + Nothing -> Nothing + Just (pn,_) -> Just pn) + ideRef <- ask + return () + +trigger :: Maybe String -> Maybe String -> IDEAction +trigger s1 s2 = do + st <- ask + triggerEvent st (RecordHistory ((PaneSelected s1), PaneSelected s2)) + triggerEvent st (Sensitivity [(SensitivityEditor, False)]) + return () + +deactivatePane :: IDEAction +deactivatePane = do + ideR <- ask + mbAP <- getActivePaneSt + case mbAP of + Nothing -> return () + Just (pn, _) -> do + deactivatePaneWithout + triggerEvent ideR (RecordHistory (PaneSelected Nothing, + PaneSelected (Just pn))) + triggerEvent ideR (Sensitivity [(SensitivityEditor, False)]) + return () + +deactivatePaneWithout :: IDEAction +deactivatePaneWithout = do + sb <- getSBActivePane + liftIO $ statusbarPop sb 1 + liftIO $ statusbarPush sb 1 "" + mbAP <- getActivePaneSt + case mbAP of + Just (_,signals) -> liftIO $do + signalDisconnectAll signals + Nothing -> return () + setActivePaneSt Nothing + +deactivatePaneIfActive :: Pane alpha IDEM => alpha -> IDEAction +deactivatePaneIfActive pane = do + mbActive <- getActivePaneSt + case mbActive of + Nothing -> return () + Just (n,_) -> if n == paneName pane + then deactivatePane + else return () + + +-- get widget elements (menu) + +getCandyState :: PaneMonad alpha => alpha (Bool) +getCandyState = do + ui <- getUIAction "ui/menubar/_Edit/Source Candy" castToToggleAction + liftIO $toggleActionGetActive ui + +setCandyState :: PaneMonad alpha => Bool -> alpha () +setCandyState b = do + ui <- getUIAction "ui/menubar/_Edit/Source Candy" castToToggleAction + liftIO $toggleActionSetActive ui b + +getForgetSession :: PaneMonad alpha => alpha (Bool) +getForgetSession = do + ui <- getUIAction "ui/menubar/_Session/Forget Session" castToToggleAction + liftIO $toggleActionGetActive ui + +-- (toolbar) + +getSBSpecialKeys :: PaneMonad alpha => alpha Statusbar +getSBSpecialKeys = widgetGet ["topBox","statusBox","statusBarSpecialKeys"] castToStatusbar + +getSBActivePane :: PaneMonad alpha => alpha Statusbar +getSBActivePane = widgetGet ["topBox","statusBox","statusBarActivePane"] castToStatusbar + +getSBActivePackage :: PaneMonad alpha => alpha Statusbar +getSBActivePackage = widgetGet ["topBox","statusBox","statusBarActiveProject"] castToStatusbar + +getSBErrors :: PaneMonad alpha => alpha Statusbar +getSBErrors = widgetGet ["topBox","statusBox","statusBarErrors"] castToStatusbar + +getStatusbarIO :: PaneMonad alpha => alpha Statusbar +getStatusbarIO = widgetGet ["topBox","statusBox","statusBarInsertOverwrite"] castToStatusbar + +getStatusbarLC :: PaneMonad alpha => alpha Statusbar +getStatusbarLC = widgetGet ["topBox","statusBox","statusBarLineColumn"] castToStatusbar + + + diff --git a/src/IDE/Core/State.hs-boot b/src/IDE/Core/State.hs-boot deleted file mode 100644 --- a/src/IDE/Core/State.hs-boot +++ /dev/null @@ -1,20 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -module IDE.Core.State ( - IDEObject -, IDERef -, IDEM -, IDEAction -) where - -import Data.IORef -import Control.Monad.Reader - - -class IDEObject o - -data IDE -type IDERef = IORef IDE -type IDEM = ReaderT (IDERef) IO -type IDEAction = IDEM () - - diff --git a/src/IDE/Core/Types.hs b/src/IDE/Core/Types.hs --- a/src/IDE/Core/Types.hs +++ b/src/IDE/Core/Types.hs @@ -1,11 +1,11 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} +{-# OPTIONS_GHC -XDisambiguateRecordFields -XExistentialQuantification -XRank2Types #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Core.Data -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL -- --- Maintainer : Juergen Nicklisch-Franken +-- Maintainer : Juergen Nicklisch-Franken -- Stability : experimental -- Portability : portable -- @@ -16,9 +16,7 @@ ------------------------------------------------------------------------------- module IDE.Core.Types ( - IDEPackage(..) -, StandardPath(..) , ActionDescr(..) , ActionString @@ -30,14 +28,22 @@ , PackageDescr(..) , ModuleDescr(..) -, IdentifierDescr(..) +, Descr(..) +, SpDescr(..) +, DescrType(..) +, descrName +, typeInfo +, descrModu +, mbLocation +, mbComment +, details +, descrType +, stockIdFromType +, isReexported , Symbol , ClassId , DataId , TypeInfo -, ModuleIdentifier -, IdType(..) -, IdTypeS(..) , SymbolTable , PackageScope , PackModule(..) @@ -45,13 +51,6 @@ , parsePackModule , fromPackageIdentifier , toPackageIdentifier -, idDescriptionsPD -, allFieldsID -, allConstructorsID -, allClassOpsID -, typeInfo -, idType - , Location(..) , Scope(..) @@ -63,26 +62,35 @@ , SpecialKeyTable , SpecialKeyCons +, LogTag(..) + +, GUIHistory +, GUIHistory'(..) + +, SensitivityMask(..) +, SearchMode(..) ) where import Control.Monad.Reader import Graphics.UI.Gtk hiding (get) -import Distribution.Package -import Distribution.Version -import Data.Map (Map) +import Graphics.UI.Gtk.Gdk.Events(Modifier(..)) 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 GHC(Ghc) -import IDE.Utils.Default -import IDE.Core.Exception +import Default +import IDE.Exception +import Graphics.UI.Frame.Panes +import Data.ByteString (ByteString(..)) +import Distribution.Package (PackageIdentifier(..),Dependency(..)) +import Distribution.Text +import Data.Map (Map(..)) +import Distribution.ModuleName(ModuleName) +import Distribution.Text +import qualified Data.ByteString as BS (empty) -data StandardPath = LeftTop | LeftBottom | RightTop | RightBottom - deriving(Read,Show,Eq,Enum) -- --------------------------------------------------------------------- -- IDEPackages @@ -116,7 +124,7 @@ , label :: String , tooltip :: Maybe String , stockID :: Maybe String -, action :: ReaderT alpha IO () +, action :: ReaderT alpha Ghc () , accelerator :: [KeyString] , isToggle :: Bool } @@ -128,36 +136,32 @@ -- | 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] + showLineNumbers :: Bool + , rightMargin :: Maybe Int + , tabWidth :: Int + , sourceCandy :: Maybe String + , keymapName :: String + , forceLineEnds :: Bool + , removeTBlanks :: Bool + , textviewFont :: Maybe String + , sourceStyle :: Maybe String + , logviewFont :: Maybe String + , defaultSize :: (Int,Int) + , browser :: String + , sourcePanePath :: StandardPath + , logPanePath :: StandardPath + , modulesPanePath :: StandardPath + , sourceDirectories :: [FilePath] + , packageBlacklist :: [Dependency] + , collectAfterBuild :: Bool + , collectAtStart :: Bool } deriving(Eq,Show) data SearchHint = Forward | Backward | Insert | Delete | Initial deriving (Eq) - - -instance Show Modifier - where show Shift = "" - show Control = "" - show Alt = "" - show Apple = "" - show Compose = "" +instance Ord Modifier + where compare a b = compare (fromEnum a) (fromEnum b) -- -- | Other types @@ -176,7 +180,7 @@ -- type PackageScope = (Map PackageIdentifier PackageDescr,SymbolTable) -type SymbolTable = Map Symbol [IdentifierDescr] +type SymbolTable = Map Symbol [Descr] data PackageDescr = PackageDescr { packagePD :: PackageIdentifier @@ -186,7 +190,7 @@ } deriving Show instance Eq PackageDescr where - (==) a b = packagePD a == packagePD b + (== ) a b = packagePD a == packagePD b instance Ord PackageDescr where (<=) a b = packagePD a <= packagePD b @@ -196,140 +200,143 @@ moduleIdMD :: PackModule , mbSourcePathMD :: (Maybe FilePath) , exportedNamesMD :: (Set Symbol) -- unqualified -, usagesMD :: (Map ModuleIdentifier (Set Symbol)) -- imports -, idDescriptionsMD :: [IdentifierDescr] +, usagesMD :: (Map ModuleName (Set Symbol)) -- imports +, idDescriptionsMD :: [Descr] } deriving Show instance Eq ModuleDescr where - (==) a b = moduleIdMD a == moduleIdMD b + (== ) 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)} +data Descr = Descr { + descrName' :: Symbol +, typeInfo' :: TypeInfo +, descrModu' :: PackModule +, mbLocation' :: Maybe Location +, mbComment' :: Maybe ByteString +, details' :: SpDescr} + | Reexported { + descrModu' :: PackModule +, impDescr :: Descr} deriving (Show,Read) -instance Eq IdentifierDescr where - (==) a b = identifierID a == identifierID b - && typeInfo a == typeInfo b +isReexported :: Descr -> Bool +isReexported (Reexported _ _) = True +isReexported _ = False -instance Ord IdentifierDescr where - (<=) a b = if identifierID a == identifierID b - then typeInfo a <= typeInfo b - else identifierID a < identifierID b +descrName :: Descr -> Symbol +descrName d + | isReexported d = descrName (impDescr d) + | otherwise = descrName' d +typeInfo :: Descr -> TypeInfo +typeInfo d + | isReexported d = typeInfo (impDescr d) + | otherwise = typeInfo' d -allFieldsID :: IdentifierDescr -> [Symbol] -allFieldsID (DataDescr _ _ _ _ fieldsId _ _) = fieldsId -allFieldsID _ = [] +descrModu :: Descr -> PackModule +descrModu d + | isReexported d = descrModu (impDescr d) + | otherwise = descrModu' d -allConstructorsID :: IdentifierDescr -> [Symbol] -allConstructorsID (DataDescr _ _ _ constructorsID _ _ _) = constructorsID -allConstructorsID _ = [] +mbLocation :: Descr -> Maybe Location +mbLocation d + | isReexported d = mbLocation (impDescr d) + | otherwise = mbLocation' d -allClassOpsID :: IdentifierDescr -> [Symbol] -allClassOpsID (ClassDescr _ _ _ classOpsID _ _) = classOpsID -allClassOpsID _ = [] +mbComment :: Descr -> Maybe ByteString +mbComment d + | isReexported d = mbComment (impDescr d) + | otherwise = mbComment' d -typeInfo :: IdentifierDescr -> TypeInfo -typeInfo (SimpleDescr _ _ ti _ _ _) = ti -typeInfo (DataDescr _ ti _ _ _ _ _) = ti -typeInfo (ClassDescr _ ti _ _ _ _) = ti -typeInfo (InstanceDescr _ _ _ _ _) = BS.pack "" +details :: Descr -> SpDescr +details d + | isReexported d = details (impDescr d) + | otherwise = details' d -idDescriptionsPD :: PackageDescr -> [IdentifierDescr] -idDescriptionsPD pd = concatMap idDescriptionsMD (exposedModulesPD pd) -instance Default IdentifierDescr where - getDefault = SimpleDescr getDefault getDefault getDefault getDefault getDefault - getDefault +data SpDescr = VariableDescr + | FieldDescr {typeDescrF :: Descr} + | ConstructorDescr {typeDescrC :: Descr} + | DataDescr {constructors :: [(Symbol,TypeInfo)], + fields :: [(Symbol,TypeInfo)]} + | TypeDescr + | NewtypeDescr {constructor :: (Symbol,TypeInfo), + mbField :: Maybe (Symbol,TypeInfo)} + | ClassDescr {super :: [Symbol], methods :: [(Symbol,TypeInfo)]} + | MethodDescr {classDescrM :: Descr} + | InstanceDescr {binds :: [Symbol]} + --the descrName is the type Konstructor? + deriving (Show,Read,Eq,Ord) -data IdType = Function | Newtype | Type | AbstractData | OpenData | Foreign - | Data | Class | Instance | Constructor | Field | Method | OrphanedInstance - deriving (Show, Eq, Ord, Enum, Read) +instance Eq Descr where + (== ) a b = descrName a == descrName b + && descrType (details a) == descrType (details b) -instance Default IdType where - getDefault = Function +instance Ord Descr where + (<=) a b = if descrName a == descrName b + then descrType (details a) <= descrType (details b) + else descrName a < descrName b -data IdTypeS = FunctionS | NewtypeS | TypeS | AbstractDataS | OpenDataS | ForeignS - deriving (Show, Eq, Ord, Enum, Read) +data DescrType = Variable | Field | Constructor | Data | Type | Newtype + | Class | Method | Instance + deriving (Show, Eq, Ord, Bounded, Enum, Read) -instance Default IdTypeS where - getDefault = FunctionS +instance Default DescrType where + getDefault = Variable -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 +descrType :: SpDescr -> DescrType +descrType VariableDescr = Variable +descrType (FieldDescr _) = Field +descrType (ConstructorDescr _) = Constructor +descrType (DataDescr _ _) = Data +descrType TypeDescr = Type +descrType (NewtypeDescr _ _) = Newtype +descrType (ClassDescr _ _) = Class +descrType (MethodDescr _) = Method +descrType (InstanceDescr _) = Instance +stockIdFromType :: DescrType -> StockId +stockIdFromType Variable = "ide_function" +stockIdFromType Newtype = "ide_newtype" +stockIdFromType Type = "ide_type" +stockIdFromType Data = "ide_data" +stockIdFromType Class = "ide_class" +stockIdFromType Instance = "ide_instance" +stockIdFromType Constructor = "ide_konstructor" +stockIdFromType Field = "ide_slot" +stockIdFromType Method = "ide_method" + 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 +--type ModuleIdentifier = String -- always qualified data PackModule = PM { pack :: PackageIdentifier - , modu :: ModuleIdentifier} + , modu :: ModuleName} deriving (Eq, Ord,Read,Show) - - showPackModule :: PackModule -> String -showPackModule (PM p m) = showPackageId p ++ ":" ++ m +showPackModule (PM p m) = display p ++ ":" ++ display 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')) + in case toPackageIdentifier $ pack' of + Nothing -> perror $ "Types>>parsePackModule: Can't parse package:" ++ str + Just pi'-> case simpleParse $ tail mod' of + Nothing -> perror $ + "Types>>parsePackModule: Can't parse module:" ++ str + Just mn -> (PM pi' mn) where perror s = throwIDE $ "cannot parse PackModule from " ++ s fromPackageIdentifier :: PackageIdentifier -> String -fromPackageIdentifier = showPackageId +fromPackageIdentifier = display 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) +toPackageIdentifier = simpleParse instance Default PackModule where getDefault = parsePackModule "unknow-0:Undefined" @@ -344,7 +351,7 @@ instance Default ByteString where getDefault = BS.empty -data Scope = World | Package | Local +data Scope = Local | Package | System deriving (Show, Eq, Ord, Enum, Read) newtype CandyTable = CT (CandyTableForth,CandyTableBack) @@ -360,6 +367,36 @@ type SpecialKeyCons alpha = Maybe ((Map (KeyVal,[Modifier]) (ActionDescr alpha)),String) +data LogTag = LogTag | ErrorTag | FrameTag + +-- | the first one is the new and the second the old state +type GUIHistory = (GUIHistory', GUIHistory') + +data GUIHistory' = + ModuleSelected { + moduleS :: Maybe ModuleName + , facetS :: Maybe Symbol} + | ScopeSelected { + scope :: Scope + , blacklist :: Bool} + | InfoElementSelected { + info :: Descr} + | PaneSelected { + paneN :: Maybe (String)} + deriving (Eq, Ord, Show) + +data SensitivityMask = + SensitivityForwardHist + | SensitivityBackwardHist + | SensitivityProjectActive + | SensitivityError + | SensitivityEditor + + deriving (Eq, Ord, Show) + +data SearchMode = Exact {caseSense :: Bool} | Prefix {caseSense :: Bool} + | Regex {caseSense :: Bool} + deriving (Eq,Ord,Read,Show) diff --git a/src/IDE/DescriptionPP.hs b/src/IDE/DescriptionPP.hs --- a/src/IDE/DescriptionPP.hs +++ b/src/IDE/DescriptionPP.hs @@ -4,31 +4,33 @@ -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL -- --- Maintainer : Juergen Nicklisch-Franken +-- Maintainer : Juergen Nicklisch-Franken -- Stability : experimental -- Portability : portable -- --- | Description with additional fileds for printing and parsing +-- | Description of a editor with additional fileds for printing and parsing -- ----------------------------------------------------------------------------------- module IDE.DescriptionPP ( Applicator , FieldDescriptionPP(..) , mkFieldPP +, extractFieldDescription +, flattenFieldDescriptionPP ) where -import Graphics.UI.Gtk hiding (Event) +import Graphics.UI.Gtk 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 Graphics.UI.Editor.Parameters +--import Graphics.UI.Editor.Basics +import Graphics.UI.Editor.MakeEditor import IDE.Core.State - -type Applicator alpha = alpha -> IDEAction +import Graphics.UI.Editor.Basics (Applicator(..),Editor(..),Setter(..),Getter(..),Notifier(..),Extractor(..),Injector(..)) data FieldDescriptionPP alpha = FDPP { parameters :: Parameters @@ -37,6 +39,9 @@ , fieldEditor :: alpha -> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier) , applicator :: alpha -> alpha -> IDEAction } + | VFDPP Parameters [FieldDescriptionPP alpha] + | HFDPP Parameters [FieldDescriptionPP alpha] + | NFDPP [(String,FieldDescriptionPP alpha)] type MkFieldDescriptionPP alpha beta = Parameters -> @@ -45,12 +50,13 @@ (Getter alpha beta) -> (Setter alpha beta) -> (Editor beta) -> - (Applicator beta) -> + (Applicator beta IDEM) -> FieldDescriptionPP alpha mkFieldPP :: Eq beta => MkFieldDescriptionPP alpha beta -mkFieldPP parameters printer parser getter setter editor applicator = - FDPP parameters +mkFieldPP parameters printer parser getter setter editor applicator = + let FD _ ed = mkField parameters getter setter editor + in FDPP parameters (\ dat -> (PP.text (case getParameterPrim paraName parameters of Nothing -> "" Just str -> str) PP.<> PP.colon) @@ -65,31 +71,26 @@ 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 + ed + (\ newDat oldDat -> do --applicator let newField = getter newDat let oldField = getter oldDat if newField == oldField then return () else applicator newField) + +extractFieldDescription :: FieldDescriptionPP alpha -> FieldDescription alpha +extractFieldDescription (VFDPP paras descrs) = VFD paras (map extractFieldDescription descrs) +extractFieldDescription (HFDPP paras descrs) = HFD paras (map extractFieldDescription descrs) +extractFieldDescription (NFDPP descrsp) = NFD (map (\(s,d) -> + (s, extractFieldDescription d)) descrsp) +extractFieldDescription (FDPP parameters fieldPrinter fieldParser fieldEditor applicator) = + (FD parameters fieldEditor) + +flattenFieldDescriptionPP :: FieldDescriptionPP alpha -> [FieldDescriptionPP alpha] +flattenFieldDescriptionPP (VFDPP paras descrs) = concatMap flattenFieldDescriptionPP descrs +flattenFieldDescriptionPP (HFDPP paras descrs) = concatMap flattenFieldDescriptionPP descrs +flattenFieldDescriptionPP (NFDPP descrsp) = concatMap (flattenFieldDescriptionPP . snd) descrsp +flattenFieldDescriptionPP fdpp = [fdpp] diff --git a/src/IDE/Exception.hs b/src/IDE/Exception.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Exception.hs @@ -0,0 +1,95 @@ +{-# OPTIONS_GHC -XScopedTypeVariables -XDeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Exception +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | A Type for IDE exceptions +-- Taken from Haddock example. +-- +------------------------------------------------------------------------------- + +module IDE.Exception ( + IDEException +, throwIDE +, handleTopExceptions +) where + +import Data.Typeable +import System.IO +import Prelude hiding(catch) +import System.Exit + +import Debug.Trace +import Control.OldException (Exception(..),throwDyn) +import Control.Exception (catch) +import GHC.IOBase (AsyncException(..)) + +data IDEException = IDEException String + deriving Typeable + +instance Show IDEException where + show (IDEException str) = str + +throwIDE str = trace str (throwDyn (IDEException str)) + +sysMessage' :: MessageLevel -> String -> IO () +sysMessage' ml str = do + putStrLn str + hFlush stdout + +data MessageLevel = Silent | Normal | High + deriving (Eq,Ord,Show) + + +-- --------------------------------------------------------------------- +-- Exception handling +-- + +handleTopExceptions = + handleNormalExceptions -- . handleIDEExceptions . handleGhcExceptions + +handleNormalExceptions inner = + catch inner (\exception -> do + hFlush stdout + case exception of + AsyncException StackOverflow -> do + sysMessage' Normal "stack overflow: use -g +RTS -K to increase it" + exitFailure + ExitException code -> exitWith code + _other -> do + sysMessage' Normal ("ide: internal IDE error: " ++ show exception) + exitFailure + ) + +{-- +handleIDEExceptions inner = + catchDyn inner (\(e::IDEException) -> do + sysMessage' Normal $ "ide: " ++ (show e) + exitFailure + ) + + +handleGhcExceptions inner = + -- throwIDE messages propagated as exceptions + let inner2 = catchDyn inner (\(dyn::GhcException) -> do + hFlush stdout + case dyn of + PhaseFailed _ code -> exitWith code + Interrupted -> exitFailure + _ -> do + print dyn + exitFailure) + in + -- compilation errors: messages with locations attached + catchDyn inner2 (\dyn -> do + sysMessage' Normal "ide: Compilation error(s):" + printBagOfErrors defaultDynFlags (unitBag dyn) + exitFailure + ) +--} diff --git a/src/IDE/FileUtils.hs b/src/IDE/FileUtils.hs new file mode 100644 --- /dev/null +++ b/src/IDE/FileUtils.hs @@ -0,0 +1,304 @@ +module IDE.FileUtils ( + allModules +, allHiFiles +, allHaskellSourceFiles +, cabalFileName +, allCabalFiles +, getConfigFilePathForLoad +, hasConfigDir +, getConfigDir +, getConfigFilePathForSave +, getCollectorPath +, getSysLibDir +, moduleNameFromFilePath +, findKnownPackages +, isSubPath +, findSourceFile + +, getInstalledPackageInfos +, findFittingPackages +) where + +import System.FilePath +import System.Directory +import System.IO +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 Control.Monad.Trans(MonadIO,liftIO) +import qualified Data.List as List +import qualified Data.Set as Set +import Data.Set (Set) +import Data.List (maximumBy,isSuffixOf,isPrefixOf) +import Distribution.ModuleName(ModuleName,toFilePath) +import Distribution.Text(simpleParse) +import Debug.Trace + +import Paths_leksah +import IDE.Core.State +import GHC (setSessionDynFlags,getSessionDynFlags,Ghc(..)) +import PackageConfig (PackageConfig(..)) +import DynFlags (DynFlag(..),flags,pkgDatabase) +import UniqFM (eltsUFM) +import Distribution.Simple (PackageIdentifier(..),Dependency(..)) +import qualified Distribution.InstalledPackageInfo as IPI (package) +import Distribution.Version (withinRange) +import Distribution.Package (pkgVersion) +import Data.Char (ord) + +-- | 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] + -> ModuleName + -> IO (Maybe FilePath) +findSourceFile directories exts modId = + let modulePath = toFilePath 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 [ModuleName] +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] -> FilePath -> IO [FilePath] +allFilesWithExtensions extensions recurseFurther collecting filePath = do + exists <- trace ("allFilesWithExtensions " ++ filePath) $ 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 + allFiles <- + if recurseFurther || (not recurseFurther && null choosenFiles) + then foldM (allFilesWithExtensions extensions recurseFurther) (choosenFiles ++ collecting) dirs + else return (choosenFiles ++ collecting) + return (allFiles) + else return collecting + + + +moduleNameFromFilePath :: FilePath -> IO (Maybe ModuleName) +moduleNameFromFilePath fp = do + exists <- doesFileExist fp + if exists + then do + str <- readFile fp + let unlitRes = if takeExtension fp == ".lhs" + then unlit fp str + else Left str + case unlitRes of + Right err -> do + sysMessage Normal $show err + return Nothing + Left str' -> do + let parseRes = parse moduleNameParser fp str' + case parseRes of + Left err -> do + sysMessage Normal $show err + return Nothing + Right str -> do + let res = simpleParse str + case res of + Nothing -> do + sysMessage Normal $ "FileUtils>>moduleNameFromFilePath " ++ + "Can't parse module name " ++ str + return Nothing + Just mn -> return (Just mn) + 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 :: MonadIO m => String -> m FilePath +getCollectorPath version = liftIO $ 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 List.init libDir + else libDir + trace ("getSysLibDir " ++ libDir2) $ waitForProcess pid + return (normalise libDir2) + +-- --------------------------------------------------------------------- +-- The (mothers) little helpers +-- + +getInstalledPackageInfos :: Ghc [PackageConfig] +getInstalledPackageInfos = do + dflags1 <- getSessionDynFlags + setSessionDynFlags dflags1{flags = Opt_ReadUserPackageConf : (flags dflags1)} + pkgInfos <- case pkgDatabase dflags1 of + Nothing -> return [] + Just fm -> return (eltsUFM fm) + return pkgInfos + +findFittingPackages :: [Dependency] -> Ghc [PackageIdentifier] +findFittingPackages dependencyList = do + knownPackages <- getInstalledPackageInfos + let packages = map IPI.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 + + + + diff --git a/src/IDE/Find.hs b/src/IDE/Find.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Find.hs @@ -0,0 +1,504 @@ +{-# OPTIONS_GHC -XScopedTypeVariables -XDeriveDataTypeable -XMultiParamTypeClasses + -XTypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Find +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | The toolbar for searching and replacing in a text buffer +-- +------------------------------------------------------------------------------- + +module IDE.Find ( + toggleFindbar +, constructFindReplace +, hideFindbar +, showFindbar +, focusFindEntry +, editFindInc +, editGotoLine +, FindState(..) +, getFindState +, setFindState +, editFind + +, showToolbar +, hideToolbar +, toggleToolbar + + +) where + +import Graphics.UI.Gtk hiding (get) +import Graphics.UI.Gtk.SourceView +import Graphics.UI.Gtk.Gdk.Events +import Data.Maybe +import Control.Monad.Reader +import Data.List + +import IDE.Core.State +import IDE.Pane.SourceBuffer +import Data.Char (toUpper) +import Debug.Trace + +data FindState = FindState { + entryStr :: String + , entryHist :: [String] + , replaceStr :: String + , replaceHist :: [String] + , caseSensitive :: Bool + , entireWord :: Bool + , wrapAround :: Bool + , backward :: Bool + , lineNr :: Int} + deriving(Eq,Ord,Show,Read) + +getFindState :: IDEM FindState +getFindState = do + fb <- readIDE findbar + liftIO $ do + lineNr <- getLineEntry fb >>= (\e -> spinButtonGetValueAsInt (castToSpinButton e)) + replaceStr <- getReplaceEntry fb >>= (\e -> entryGetText (castToEntry e)) + entryStr <- getFindEntry fb >>= (\e -> entryGetText (castToEntry e)) + entireWord <- getEntireWord fb + wrapAround <- getWrapAround fb + caseSensitive <- getCaseSensitive fb + backward <- getBackward fb + return FindState{ + entryStr = entryStr + , entryHist = [] + , replaceStr = replaceStr + , replaceHist = [] + , caseSensitive = caseSensitive + , entireWord = entireWord + , wrapAround = wrapAround + , backward = backward + , lineNr = lineNr} + +setFindState :: FindState -> IDEAction +setFindState fs = do + fb <- readIDE findbar + liftIO $ do + getLineEntry fb >>= (\e -> spinButtonSetValue (castToSpinButton e) (fromIntegral (lineNr fs))) + getReplaceEntry fb >>= (\e -> entrySetText (castToEntry e) (replaceStr fs)) + getFindEntry fb >>= (\e -> entrySetText (castToEntry e) (entryStr fs)) + setEntireWord fb (entireWord fs) + setWrapAround fb (wrapAround fs) + setCaseSensitive fb (caseSensitive fs) + setBackward fb (backward fs) + + +hideToolbar :: IDEAction +hideToolbar = do + mbtb <- trace "hide tool bar" $ readIDE toolbar + case mbtb of + Nothing -> return () + Just tb -> do + modifyIDE_ (\ide -> return (ide{toolbarVisible = False})) + liftIO $ widgetHideAll tb + +showToolbar :: IDEAction +showToolbar = do + mbtb <- readIDE toolbar + case mbtb of + Nothing -> return () + Just tb -> do + modifyIDE_ (\ide -> return (ide{toolbarVisible = True})) + liftIO $ widgetShowAll tb + +toggleToolbar :: IDEAction +toggleToolbar = do + toolBarVisible' <- readIDE toolbarVisible + if toolBarVisible' + then hideToolbar + else showToolbar + +hideFindbar :: IDEAction +hideFindbar = do + fb <- readIDE findbar + modifyIDE_ (\ide -> return (ide{findbarVisible = False})) + liftIO $ widgetHideAll fb + +showFindbar :: IDEAction +showFindbar = do + fb <- readIDE findbar + modifyIDE_ (\ide -> return (ide{findbarVisible = True})) + liftIO $ widgetShowAll fb + +focusFindEntry :: IDEAction +focusFindEntry = do + fb <- readIDE findbar + findbarVisible' <- readIDE findbarVisible + when findbarVisible' $ liftIO $ do + entry <- getFindEntry fb + widgetGrabFocus entry + + + +toggleFindbar :: IDEAction +toggleFindbar = do + findbarVisible' <- readIDE findbarVisible + if findbarVisible' + then hideFindbar + else showFindbar + +constructFindReplace :: Toolbar -> IDEM (Toolbar) +constructFindReplace toolbar = reifyIDE $ \ ideR session -> do + closeButton <- toolButtonNewFromStock "gtk-close" + toolbarInsert toolbar closeButton 0 + + sep0 <- separatorToolItemNew + separatorToolItemSetDraw sep0 False + toolItemSetExpand sep0 True + toolbarInsert toolbar sep0 0 + + spinTool <- toolItemNew + spinL <- spinButtonNewWithRange 1.0 1000.0 10.0 + widgetSetName spinL "gotoLineEntry" + containerAdd spinTool spinL + widgetSetName spinTool "gotoLineEntryTool" + toolbarInsert toolbar spinTool 0 + + labelTool3 <- toolItemNew + label3 <- labelNew (Just "Goto Line :") + containerAdd labelTool3 label3 + toolbarInsert toolbar labelTool3 0 + + sep1 <- separatorToolItemNew + toolbarInsert toolbar sep1 0 + + replaceAllButton <- toolButtonNew (Nothing :: Maybe Widget) (Just "Replace All") + toolbarInsert toolbar replaceAllButton 0 + + replaceButton <- toolButtonNewFromStock "gtk-find-and-replace" + toolbarInsert toolbar replaceButton 0 + + replaceTool <- toolItemNew + rentry <- entryNew + widgetSetName rentry "replaceEntry" + containerAdd replaceTool rentry + widgetSetName replaceTool "replaceTool" + toolbarInsert toolbar replaceTool 0 + + labelTool2 <- toolItemNew + label2 <- labelNew (Just "Replace: ") + containerAdd labelTool2 label2 + toolbarInsert toolbar labelTool2 0 + + sep2 <- separatorToolItemNew + toolbarInsert toolbar sep2 0 + + backwardButton <- toggleToolButtonNew + toolButtonSetLabel backwardButton (Just "Backward") + widgetSetName backwardButton "backwardButton" + toolbarInsert toolbar backwardButton 0 + + wrapAroundButton <- toggleToolButtonNew + toolButtonSetLabel wrapAroundButton (Just "Wrap around") + widgetSetName wrapAroundButton "wrapAroundButton" + toolbarInsert toolbar wrapAroundButton 0 + + entireWordButton <- toggleToolButtonNew + toolButtonSetLabel entireWordButton (Just "Entire word") + widgetSetName entireWordButton "entireWordButton" + toolbarInsert toolbar entireWordButton 0 + + caseSensitiveButton <- toggleToolButtonNew + toolButtonSetLabel caseSensitiveButton (Just "Case sensitive") + widgetSetName caseSensitiveButton "caseSensitiveButton" + toolbarInsert toolbar caseSensitiveButton 0 + + findButton <- toolButtonNewFromStock "gtk-find" + toolbarInsert toolbar findButton 0 + + entryTool <- toolItemNew + entry <- entryNew + widgetSetName entry "searchEntry" + containerAdd entryTool entry + widgetSetName entryTool "searchEntryTool" + toolbarInsert toolbar entryTool 0 + + labelTool <- toolItemNew + label <- labelNew (Just "Search: ") + containerAdd labelTool label + toolbarInsert toolbar labelTool 0 + + findButton `onToolButtonClicked` (doSearch toolbar Forward ideR session) + + entry `afterInsertText` (\t i -> do + doSearch toolbar Insert ideR session + return i) + entry `afterDeleteText` (\ _ _ -> doSearch toolbar Delete ideR session) + entry `afterKeyPress` (\ e -> case e of + k@(Key _ _ _ _ _ _ _ _ _ _) + | eventKeyName k == "Down" -> do + doSearch toolbar Forward ideR session + return True + | eventKeyName k == "Up" -> do + doSearch toolbar Backward ideR session + return True + | eventKeyName k == "Escape" -> do + getOut ideR session + return True + | otherwise -> return True + _ -> return True) + entry `onEntryActivate` getOut ideR session + replaceButton `onToolButtonClicked` replace toolbar Forward ideR session + + replaceAllButton `onToolButtonClicked` replaceAll toolbar Forward ideR session + + + spinL `afterFocusIn` (\ _ -> (reflectIDE (inBufContext True $ \_ gtkbuf currentBuffer _ -> do + max <- textBufferGetLineCount gtkbuf + spinButtonSetRange spinL 1.0 (fromIntegral max) + return True) ideR session)) + + + spinL `afterEntryActivate` (reflectIDE (inBufContext () $ \_ gtkbuf currentBuffer _ -> do + line <- spinButtonGetValueAsInt spinL + iter <- textBufferGetStartIter gtkbuf + textIterSetLine iter (line - 1) + textBufferPlaceCursor gtkbuf iter + textViewScrollToIter (sourceView currentBuffer) iter 0.2 Nothing + return ()) ideR session) + + closeButton `onToolButtonClicked` do + reflectIDE hideFindbar ideR session + + set toolbar [ toolbarChildHomogeneous spinTool := False ] + set toolbar [ toolbarChildHomogeneous wrapAroundButton := False ] + set toolbar [ toolbarChildHomogeneous entireWordButton := False ] + set toolbar [ toolbarChildHomogeneous caseSensitiveButton := False ] + set toolbar [ toolbarChildHomogeneous backwardButton := False ] + set toolbar [ toolbarChildHomogeneous replaceAllButton := False ] + set toolbar [ toolbarChildHomogeneous labelTool := False ] + set toolbar [ toolbarChildHomogeneous labelTool2 := False ] + set toolbar [ toolbarChildHomogeneous labelTool3 := False ] + + return toolbar + where getOut = reflectIDE $ do + hideFindbar + mbbuf <- maybeActiveBuf + case mbbuf of + Nothing -> return () + Just buf -> do + liftIO $ widgetGrabFocus (sourceView buf) + return () + + +doSearch :: Toolbar -> SearchHint -> IDERef -> Session -> IO () +doSearch fb hint ideR session = do + entry <- getFindEntry fb + search <- entryGetText (castToEntry entry) + entireWord <- getEntireWord fb + caseSensitive <- getCaseSensitive fb + wrapAround <- getWrapAround fb + res <- reflectIDE (editFind entireWord caseSensitive wrapAround search "" hint) ideR session + if res || null search + then do + widgetModifyBase entry StateNormal white + widgetModifyText entry StateNormal black + else do + widgetModifyBase entry StateNormal red + widgetModifyText entry StateNormal white + return () + +replace :: Toolbar -> SearchHint -> IDERef -> Session -> IO () +replace fb hint ideR session = do + entry <- getFindEntry fb + search <- entryGetText (castToEntry entry) + rentry <- getReplaceEntry fb + replace <- entryGetText (castToEntry rentry) + entireWord <- getEntireWord fb + caseSensitive <- getCaseSensitive fb + wrapAround <- getWrapAround fb + found <- reflectIDE (editReplace entireWord caseSensitive wrapAround search replace hint) + ideR session + return () + + +replaceAll :: Toolbar -> SearchHint -> IDERef -> Session -> IO () +replaceAll fb hint ideR session = do + entry <- getFindEntry fb + search <- entryGetText (castToEntry entry) + rentry <- getReplaceEntry fb + replace <- entryGetText (castToEntry rentry) + entireWord <- getEntireWord fb + caseSensitive <- getCaseSensitive fb + wrapAround <- getWrapAround fb + found <- reflectIDE (editReplaceAll entireWord caseSensitive wrapAround search replace hint) + ideR session + return () + +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 _ -> liftIO $ 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) + +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 <- liftIO $textBufferGetInsert gtkbuf + iter <- liftIO $textBufferGetIterAtMark gtkbuf startMark + iter2 <- liftIO $textIterCopy iter + liftIO $textIterForwardChars iter2 (length search) + str1 <- liftIO $textIterGetText iter iter2 + if compare str1 search caseSensitive + then do + liftIO $textBufferDelete gtkbuf iter iter2 + liftIO $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 + +red = Color 640000 10000 10000 +white = Color 64000 64000 64000 +black = Color 0 0 0 + +editFindInc :: SearchHint -> IDEAction +editFindInc hint = do + showFindbar + fb <- readIDE findbar + reifyIDE $ \ideR session -> do + entry <- getFindEntry fb + widgetGrabFocus entry + case hint of + Forward -> doSearch fb Forward ideR session + Backward -> doSearch fb Backward ideR session + _ -> return () + +editGotoLine :: IDEAction +editGotoLine = do + showFindbar + fb <- readIDE findbar + entry <- liftIO $ getLineEntry fb + liftIO $ widgetGrabFocus entry + +getLineEntry, getReplaceEntry, getFindEntry :: Toolbar -> IO Widget +getLineEntry = getWidget "gotoLineEntryTool" +getReplaceEntry = getWidget "replaceTool" +getFindEntry = getWidget "searchEntryTool" + +getWidget :: String -> Toolbar -> IO Widget +getWidget str tb = do + widgets <- containerGetChildren tb + entryL <- filterM (\w -> liftM (== str) (widgetGetName w) ) widgets + case entryL of + [w] -> do + mbw <- binGetChild (castToBin w) + case mbw of + Nothing -> throwIDE "Find>>getWidget not found(1)" + Just w -> return w + _ -> throwIDE "Find>>getWidget not found(2)" + +getEntireWord, getWrapAround, getCaseSensitive :: Toolbar -> IO Bool +getEntireWord = getSelection "entireWordButton" +getWrapAround = getSelection "wrapAroundButton" +getCaseSensitive = getSelection "caseSensitiveButton" +getBackward = getSelection "backwardButton" + +getSelection :: String -> Toolbar -> IO Bool +getSelection str tb = do + widgets <- containerGetChildren tb + entryL <- filterM (\w -> liftM (== str) (widgetGetName w) ) widgets + case entryL of + [w] -> toggleToolButtonGetActive (castToToggleToolButton w) + _ -> throwIDE "Find>>getIt widget not found" + +setEntireWord, setWrapAround, setCaseSensitive, setBackward :: Toolbar -> Bool -> IO () +setEntireWord = setSelection "entireWordButton" +setWrapAround = setSelection "wrapAroundButton" +setCaseSensitive = setSelection "caseSensitiveButton" +setBackward = setSelection "backwardButton" + +setSelection :: String -> Toolbar -> Bool -> IO () +setSelection str tb bool = do + widgets <- containerGetChildren tb + entryL <- filterM (\w -> liftM (== str) (widgetGetName w) ) widgets + case entryL of + [w] -> toggleToolButtonSetActive (castToToggleToolButton w) bool + _ -> throwIDE "Find>>getIt widget not found" diff --git a/src/IDE/FindPane.hs b/src/IDE/FindPane.hs deleted file mode 100644 --- a/src/IDE/FindPane.hs +++ /dev/null @@ -1,361 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- --- Module : IDE.FindPane --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | The pane of ide for searching in a text buffer --- -------------------------------------------------------------------------------- - -module IDE.FindPane ( - IDEFind(..) -, FindAction(..) -, FindState(..) -, editFind -) where - -import Graphics.UI.Gtk hiding (get) -import Graphics.UI.Gtk.SourceView -import Data.Maybe -import Control.Monad.Reader -import Data.List - -import IDE.Core.State -import IDE.Framework.ViewFrame -import IDE.SourceEditor - -------------------------------------------------------------------------------- --- --- * Interface --- - -class FindAction alpha where - doFind :: alpha - editFindInc :: SearchHint -> alpha - editFindKey :: Event -> alpha - editGotoLine :: alpha - editGotoLineEnd :: alpha - editGotoLineKey :: Event -> alpha - -instance FindAction IDEAction where - doFind = doFind' - editFindInc = editFindInc' - editFindKey = editFindKey' - editGotoLine = editGotoLine' - editGotoLineEnd = editGotoLineEnd' - editGotoLineKey = editGotoLineKey' - -instance IDEObject IDEFind - -instance CastablePane IDEFind where - casting _ = FindCasting - downCast _ (PaneC a) = case casting a of - FindCasting -> Just a - _ -> Nothing - - -instance Recoverable FindState where - toPaneState a = FindSt a - -instance Pane IDEFind - where - primPaneName _ = "Find" - getAddedIndex _ = 0 - getTopWidget = castToWidget . findBox - paneId b = "*Find" - makeActive p = throwIDE "don't activate find bar" - close pane = do - (panePath,_) <- guiPropertiesFromName (paneName pane) - nb <- getNotebook panePath - mbI <- lift $notebookPageNum nb (getTopWidget pane) - case mbI of - Nothing -> lift $ do - sysMessage Normal "notebook page not found: unexpected" - return () - Just i -> do - lift $notebookRemovePage nb i - removePaneAdmin pane - - -instance RecoverablePane IDEFind FindState where - saveState p = do - mbFind <- getPane FindCasting - case mbFind of - Nothing -> return Nothing - Just p -> lift $ do - return (Just (StateC FindState)) - recoverState pp FindState = do - nb <- getNotebook pp - initFind pp nb - -------------------------------------------------------------------------------- --- --- * Implementation --- - -doFind' :: IDEAction -doFind' = do - find :: IDEFind <- getFind - lift $ bringPaneToFront find - lift $ widgetGrabFocus (getTopWidget find) - - -getFind :: IDEM IDEFind -getFind = do - mbFind <- getPane FindCasting - case mbFind of - Nothing -> do - prefs <- readIDE prefs - layout <- readIDE layout - let pp = getStandardPanePath (controlPanePath prefs) layout - nb <- getNotebook pp - initFind pp nb - mbFind <- getPane FindCasting - case mbFind of - Nothing -> throwIDE "Can't init find pane" - Just m -> return m - Just m -> return m - -initFind :: PanePath -> Notebook -> IDEAction -initFind panePath nb = do - ideR <- ask - panes <- readIDE panes - paneMap <- readIDE paneMap - prefs <- readIDE prefs - currentInfo <- readIDE currentInfo - (buf,cids) <- lift $ do - hBox <- hBoxNew False 10 - bBox <- hButtonBoxNew - - entry <- entryNew - widgetSetName entry "searchEntry" - - caseSensitiveButton <- toggleButtonNew - buttonSetLabel caseSensitiveButton "Case sensitive" - widgetSetName caseSensitiveButton "caseSensitiveButton" - - entireWordButton <- toggleButtonNew - buttonSetLabel entireWordButton "Entire word" - widgetSetName entireWordButton "entireWordButton" - - wrapAroundButton <- toggleButtonNew - buttonSetLabel wrapAroundButton "Wrap around" - toggleButtonSetActive wrapAroundButton True - widgetSetName wrapAroundButton "wrapAroundButton" - - spinL <- spinButtonNewWithRange 1.0 1000.0 10.0 - widgetSetName spinL "gotoLineEntry" - - boxPackStart hBox entry PackNatural 10 - boxPackStart bBox caseSensitiveButton PackNatural 10 - boxPackStart bBox entireWordButton PackNatural 10 - boxPackStart bBox wrapAroundButton PackNatural 10 - boxPackStart hBox bBox PackNatural 10 - boxPackStart hBox spinL PackNatural 10 - - entry `afterInsertText` (\ _ _ -> do - runReaderT ((editFindInc Insert)::IDEAction) ideR - t <- entryGetText entry - return (length t)) - entry `afterDeleteText` (\ _ _ -> do runReaderT ((editFindInc Delete)::IDEAction) - ideR; return ()) - entry `afterKeyPress` (\ e -> do runReaderT ((editFindKey e)::IDEAction) - ideR; return True) - spinL `afterKeyPress` (\ e -> do runReaderT ((editGotoLineKey e)::IDEAction) - ideR; return True) - spinL `afterEntryActivate` runReaderT editGotoLineEnd ideR - spinL `afterFocusOut` (\ _ -> do runReaderT (editGotoLineEnd::IDEAction) ideR; - return False) - let find = IDEFind hBox caseSensitiveButton wrapAroundButton entireWordButton - spinL entry - notebookInsertOrdered nb hBox (paneName find) - widgetShowAll hBox - return (find,[]) - addPaneAdmin buf (BufConnections [] [] []) panePath - lift $widgetGrabFocus (findBox buf) - -getFindEntry' :: IDEFind -> Entry -getFindEntry' f = findEntry f - -getCaseSensitive' :: IDEFind -> ToggleButton -getCaseSensitive' f = caseSensitive f - -getWrapAround' :: IDEFind -> ToggleButton -getWrapAround' f = wrapAround f - -getEntireWord' :: IDEFind -> ToggleButton -getEntireWord' f = entireWord f - -getGotoLineSpin' :: IDEFind -> SpinButton -getGotoLineSpin' f = gotoLine f - -red = Color 640000 10000 10000 -white = Color 64000 64000 64000 -black = Color 0 0 0 - -{-- can't be used currently becuase of an export error - toEnum 1 = SourceSearchVisibleOnly - toEnum 2 = SourceSearchTextOnly - toEnum 4 = SourceSearchCaseInsensitive ---} - - --- | Keys for searching -editFindKey' :: Event -> IDEAction -editFindKey' k@(Key _ _ _ _ _ _ _ _ _ _) - | eventKeyName k == "Down" = - editFindInc Forward - | eventKeyName k == "Up" = - editFindInc Backward - | eventKeyName k == "Escape" = do - --entry <- getFindEntry - inBufContext' () $ \_ gtkbuf currentBuffer _ -> lift $ do - i1 <- textBufferGetStartIter gtkbuf - i2 <- textBufferGetEndIter gtkbuf - textBufferRemoveTagByName gtkbuf "found" i1 i2 - startMark <- textBufferGetInsert gtkbuf - st1 <- textBufferGetIterAtMark gtkbuf startMark - textBufferPlaceCursor gtkbuf st1 - widgetGrabFocus $ sourceView currentBuffer - | otherwise = return () -editFindKey' _ = return () - -editFindInc' :: SearchHint -> IDEAction -editFindInc' hint = do - find :: IDEFind <- getFind - let entry = getFindEntry' find - lift $ widgetGrabFocus entry - lift $ bringPaneToFront find - when (hint == Initial) $ lift $ editableSelectRegion entry 0 (-1) - search <- lift $entryGetText entry - if null search - then return () - else do - let caseSensitiveW = getCaseSensitive' find - caseSensitive <- lift $toggleButtonGetActive caseSensitiveW - let entireWButton = getEntireWord' find - entireW <- lift $toggleButtonGetActive entireWButton - let wrapAroundButton = getWrapAround' find - wrapAround <- lift $toggleButtonGetActive wrapAroundButton - res <- editFind entireW caseSensitive wrapAround search "" hint - if res || null search - then lift $do - widgetModifyBase entry StateNormal white - widgetModifyText entry StateNormal black - else lift $do - widgetModifyBase entry StateNormal red - widgetModifyText entry StateNormal white - lift $do - widgetGrabFocus entry - editableSelectRegion entry 0 (-1) - - -editFind :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool -editFind entireWord caseSensitive wrapAround search dummy hint = - let searchflags = (if caseSensitive then [] else [toEnum 4]) ++ [toEnum 1,toEnum 2] in - if null search - then return False - else inBufContext' False $ \_ gtkbuf currentBuffer _ -> lift $ do - i1 <- textBufferGetStartIter gtkbuf - i2 <- textBufferGetEndIter gtkbuf - textBufferRemoveTagByName gtkbuf "found" i1 i2 - startMark <- textBufferGetInsert gtkbuf - st1 <- textBufferGetIterAtMark gtkbuf startMark - mbsr2 <- - if hint == Backward - then do - textIterBackwardChar st1 - textIterBackwardChar st1 - mbsr <- backSearch st1 search searchflags entireWord searchflags - case mbsr of - Nothing -> - if wrapAround - then do backSearch i2 search searchflags entireWord searchflags - else return Nothing - Just (start,end) -> return (Just (start,end)) - else do - if hint == Forward - then textIterForwardChar st1 - else return True - mbsr <- forwardSearch st1 search searchflags entireWord searchflags - case mbsr of - Nothing -> - if wrapAround - then do forwardSearch i1 search searchflags entireWord searchflags - else return Nothing - Just (start,end) -> return (Just (start,end)) - case mbsr2 of - Just (start,end) -> do --found - --widgetGrabFocus sourceView - textViewScrollToIter (sourceView currentBuffer) start 0.2 Nothing - textBufferApplyTagByName gtkbuf "found" start end - textBufferPlaceCursor gtkbuf start - return True - Nothing -> return False - where - backSearch iter string flags entireWord searchflags = do - mbsr <- sourceIterBackwardSearch iter search searchflags Nothing - case mbsr of - Nothing -> return Nothing - Just (iter1,iter2) -> - if entireWord - then do - b1 <- textIterStartsWord iter1 - b2 <- textIterEndsWord iter2 - if b1 && b2 then return $Just (iter1,iter2) else return Nothing - else return (Just (iter1,iter2)) - forwardSearch iter string flags entireWord searchflags = do - mbsr <- sourceIterForwardSearch iter search searchflags Nothing - case mbsr of - Nothing -> return Nothing - Just (iter1,iter2) -> - if entireWord - then do - b1 <- textIterStartsWord iter1 - b2 <- textIterEndsWord iter2 - if b1 && b2 then return $Just (iter1,iter2) else return Nothing - else return $Just (iter1,iter2) - -editGotoLine' :: IDEAction -editGotoLine' = inBufContext' () $ \_ gtkbuf currentBuffer _ -> do - find :: IDEFind <- getFind - let spin = getGotoLineSpin' find - lift $ bringPaneToFront find - lift $do - max <- textBufferGetLineCount gtkbuf - spinButtonSetRange spin 1.0 (fromIntegral max) - widgetGrabFocus spin - -editGotoLineKey' :: Event -> IDEAction -editGotoLineKey' k@(Key _ _ _ _ _ _ _ _ _ _) - | eventKeyName k == "Escape" = - inBufContext' () $ \_ gtkbuf currentBuffer _ -> do - find :: IDEFind <- getFind - let spin = getGotoLineSpin' find - lift $ do - widgetGrabFocus $ sourceView currentBuffer - | otherwise = return () -editGotoLineKey' _ = return () - -editGotoLineEnd' :: IDEAction -editGotoLineEnd' = inBufContext' () $ \_ gtkbuf currentBuffer _ -> do - find :: IDEFind <- getFind - let spin = getGotoLineSpin' find - lift $ bringPaneToFront find - lift $ do - line <- spinButtonGetValueAsInt spin - iter <- textBufferGetStartIter gtkbuf - textIterSetLine iter (line - 1) - textBufferPlaceCursor gtkbuf iter - textViewScrollToIter (sourceView currentBuffer) iter 0.2 Nothing - widgetGrabFocus $ sourceView currentBuffer - - - - diff --git a/src/IDE/Framework/CompositeEditors.hs b/src/IDE/Framework/CompositeEditors.hs deleted file mode 100644 --- a/src/IDE/Framework/CompositeEditors.hs +++ /dev/null @@ -1,402 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : IDE.Framework.CompositeEditors --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | Module for making composite editors --- ------------------------------------------------------------------------------------ - -module IDE.Framework.CompositeEditors ( - maybeEditor -, pairEditor -, eitherOrEditor -, multisetEditor -, ColumnDescr(..) -) where - -import Graphics.UI.Gtk -import Graphics.UI.Gtk.ModelView as New -import Control.Monad -import Data.IORef -import Data.Maybe - -import IDE.Utils.Default -import IDE.Core.Exception -import IDE.Framework.Parameters -import IDE.Framework.EditorBasics -import IDE.Framework.MakeEditor -import IDE.Framework.SimpleEditors - --- --- | An editor which composes two subeditors --- -pairEditor :: (Editor alpha, Parameters) -> (Editor beta, Parameters) -> Editor (alpha,beta) -pairEditor (fstEd,fstPara) (sndEd,sndPara) parameters = do - coreRef <- newIORef Nothing - notifier <- emptyNotifier - declareEvent FocusOut (\w h -> w `onFocusOut` do h) notifier - mkEditor - (\widget (v1,v2) -> do - core <- readIORef coreRef - case core of - Nothing -> do - fst@(fstFrame,inj1,ext1,noti1) <- fstEd fstPara - snd@(sndFrame,inj2,ext2,noti2) <- sndEd sndPara - box <- case getParameter paraDirection parameters of - Horizontal -> do - b <- hBoxNew False 1 - return (castToBox b) - Vertical -> do - b <- vBoxNew False 1 - return (castToBox b) - boxPackStart box fstFrame PackGrow 0 - boxPackStart box sndFrame PackGrow 0 - containerAdd widget box - propagateEvent FocusOut noti2 notifier - inj1 v1 - inj2 v2 - writeIORef coreRef (Just (fst,snd)) - Just ((_,inj1,_,_),(_,inj2,_,_)) -> do - inj1 v1 - inj2 v2) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just ((_,_,ext1,_),(_,_,ext2,_)) -> do - r1 <- ext1 - r2 <- ext2 - if isJust r1 && isJust r2 - then return (Just (fromJust r1,fromJust r2)) - else return Nothing) - (mkNotifier notifier) - parameters - --- --- | An editor with a subeditor which gets active, when a checkbox is selected --- or deselected (if the positive Argument is False) --- -maybeEditor :: Default beta => (Editor beta, Parameters) -> Bool -> String -> Editor (Maybe beta) -maybeEditor (childEdit, childParams) positive boolLabel parameters = do - coreRef <- newIORef Nothing - childRef <- newIORef Nothing - notifier <- emptyNotifier - declareEvent FocusOut (\w h -> w `onFocusOut` do h) notifier - mkEditor - (\widget mbVal -> do - core <- readIORef coreRef - case core of - Nothing -> do - be@(boolFrame,inj1,ext1,notifierBool) <- boolEditor - (paraName <<<- (ParaName boolLabel) $ emptyParams) - propagateEvent FocusOut notifierBool notifier - box <- case getParameter paraDirection parameters of - Horizontal -> do - b <- hBoxNew False 1 - return (castToBox b) - Vertical -> do - b <- vBoxNew False 1 - return (castToBox b) - boxPackStart box boolFrame PackNatural 0 - containerAdd widget box - notifierBool Clicked (Left (onClickedHandler widget coreRef childRef notifier)) - case mbVal of - Nothing -> do - inj1 (if positive then False else True) - Just val -> do - (childWidget,inj2,ext2,noti2) <- getChildEditor childRef childEdit childParams notifier - boxPackEnd box childWidget PackNatural 0 - widgetShowAll childWidget - inj1 (if positive then True else False) - inj2 val - writeIORef coreRef (Just (be,box)) - Just (be@(boolFrame,inj1,ext1,notiRef1),box) -> do - hasChild <- hasChildEditor childRef - case mbVal of - Nothing -> do - if hasChild - then do - (childWidget,_,_,_) <- getChildEditor childRef childEdit childParams notifier - inj1 (if positive then False else True) - widgetHideAll childWidget - else inj1 (if positive then False else True) - Just val -> do - if hasChild - then do - (childWidget,inj2,_,_) <- getChildEditor childRef childEdit childParams notifier - widgetShowAll childWidget - inj2 val - else do - (childWidget,inj2,_,_) <- getChildEditor childRef childEdit childParams notifier - boxPackEnd box childWidget PackNatural 0 - widgetShowAll childWidget - inj2 val) - (do - core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just (be@(boolFrame,inj1,ext1,notiRef1),_) -> do - bool <- ext1 - case bool of - Nothing -> return Nothing - Just bv | bv == positive -> do - (_,_,ext2,_) <- getChildEditor childRef childEdit childParams notifier - value <- ext2 - case value of - Nothing -> return Nothing - Just value -> return (Just (Just value)) - otherwise -> return (Just Nothing)) - (mkNotifier notifier) - parameters - where - onClickedHandler widget coreRef childRef notifier = (\ event -> do - core <- readIORef coreRef - case core of - Nothing -> throwIDE "Impossible" - Just (be@(boolFrame,inj1,ext1,notiRef1),vBox) -> do - mbBool <- ext1 - case mbBool of - Just bool -> - if not (bool == positive) - then do - hasChild <- hasChildEditor childRef - if hasChild - then do - (childWidget,_,_,_) <- getChildEditor childRef childEdit childParams notifier - widgetHideAll childWidget - else return () - else do - hasChild <- hasChildEditor childRef - if hasChild - then do - (childWidget,_,_,_) <- getChildEditor childRef childEdit childParams notifier - widgetShowAll childWidget - else do - (childWidget,inj2,_,_) <- getChildEditor childRef childEdit childParams notifier - boxPackEnd vBox childWidget PackNatural 0 - inj2 getDefault - widgetShowAll childWidget - Nothing -> return () - return True) - getChildEditor childRef childEditor childParams notifier = do - mb <- readIORef childRef - case mb of - Just editor -> return editor - Nothing -> do - let val = childEditor - editor@(_,_,_,cnoti) <- childEditor childParams - propagateEvent FocusOut cnoti notifier - writeIORef childRef (Just editor) - return editor - hasChildEditor childRef = do - mb <- readIORef childRef - return (isJust mb) - --- --- | An editor with a subeditor which gets active, when a checkbox is selected --- or deselected (if the positive Argument is False) -eitherOrEditor :: (Default alpha, Default beta) => (Editor alpha, Parameters) -> - (Editor beta, Parameters) -> String -> Editor (Either alpha beta) -eitherOrEditor (leftEditor,leftParams) (rightEditor,rightParams) label2 parameters = do - coreRef <- newIORef Nothing - notifier <- emptyNotifier - declareEvent FocusOut (\w h -> w `onFocusOut` do h) notifier - mkEditor - (\widget v -> do - core <- readIORef coreRef - case core of - Nothing -> do - be@(boolFrame,inj1,ext1,noti1) <- boolEditor2 label2 parameters - le@(leftFrame,inj2,ext2,noti2) <- leftEditor leftParams - re@(rightFrame,inj3,ext3,noti3) <- rightEditor rightParams - noti1 Clicked (Left (onClickedHandler widget coreRef)) - propagateEvent FocusOut noti2 notifier - propagateEvent FocusOut noti3 notifier - box <- case getParameter paraDirection parameters of - Horizontal -> do - b <- hBoxNew False 1 - return (castToBox b) - Vertical -> do - b <- vBoxNew False 1 - return (castToBox b) - boxPackStart box boolFrame PackNatural 0 - activateEvent (castToWidget box) FocusOut notifier - containerAdd widget box - case v of - Left vl -> do - boxPackStart box leftFrame PackNatural 0 - inj2 vl - inj3 getDefault - inj1 True - Right vr -> do - boxPackStart box rightFrame PackNatural 0 - inj3 vr - inj2 getDefault - inj1 False - writeIORef coreRef (Just (be,le,re,box)) - Just ((_,inj1,_,_),(leftFrame,inj2,_,_),(rightFrame,inj3,_,_),box) -> do - case v of - Left vl -> do - containerRemove box rightFrame - boxPackStart box leftFrame PackNatural 0 - inj2 vl - inj3 getDefault - inj1 True - Right vr -> do - containerRemove box leftFrame - boxPackStart box rightFrame PackNatural 0 - inj3 vr - inj2 getDefault - inj1 False) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just ((_,_,ext1,_),(_,_,ext2,_),(_,_,ext3,_),_) -> do - mbbool <- ext1 - case mbbool of - Nothing -> return Nothing - Just True -> do - value <- ext2 - case value of - Nothing -> return Nothing - Just value -> return (Just (Left value)) - Just False -> do - value <- ext3 - case value of - Nothing -> return Nothing - Just value -> return (Just (Right value))) - (mkNotifier notifier) - (paraName <<<- (ParaName "") $ parameters) - where - onClickedHandler widget coreRef = (\ event -> do - core <- readIORef coreRef - case core of - Nothing -> throwIDE "Impossible" - Just (be@(_,_,ext1,_),(leftFrame,_,_,_),(rightFrame,_,_,_),box) -> do - mbBool <- ext1 - case mbBool of - Just bool -> - if bool then do - containerRemove box rightFrame - boxPackStart box leftFrame PackNatural 0 - widgetShowAll box - else do - containerRemove box leftFrame - boxPackStart box rightFrame PackNatural 0 - widgetShowAll box - Nothing -> return () - return True) - - --- a trivial example: (ColumnDescr False [("",(\row -> [New.cellText := show row]))]) --- and a nontrivial: --- [("Package",\(Dependency str _) -> [New.cellText := str]) --- ,("Version",\(Dependency _ vers) -> [New.cellText := showVersionRange vers])]) -data ColumnDescr row = ColumnDescr Bool [(String,(row -> [AttrOp CellRendererText]))] - --- --- | An editor with a subeditor, of which a list of items can be selected -multisetEditor :: (Show alpha, Default alpha) => - ColumnDescr alpha -> (Editor alpha, Parameters) -> Editor [alpha] -multisetEditor (ColumnDescr showHeaders columnsDD) (singleEditor, sParams) parameters = do - coreRef <- newIORef Nothing - notifier <- emptyNotifier - declareEvent FocusOut (\w h -> w `onFocusOut` do h) notifier - mkEditor - (\widget v -> do - core <- readIORef coreRef - case core of - Nothing -> do - (box,buttonBox) <- case getParameter paraDirection parameters of - Horizontal -> do - b <- hBoxNew False 1 - bb <- vButtonBoxNew - return (castToBox b,castToButtonBox bb) - Vertical -> do - b <- vBoxNew False 1 - bb <- hButtonBoxNew - return (castToBox b,castToButtonBox bb) - (frameS,injS,extS,notS) <- singleEditor sParams - addButton <- buttonNewWithLabel "Add" - removeButton <- buttonNewWithLabel "Remove" - containerAdd buttonBox addButton - containerAdd buttonBox removeButton - listStore <- New.listStoreNew ([]:: [alpha]) - list <- New.treeViewNewWithModel listStore - widgetSetSizeRequest list 50 50 - sel <- New.treeViewGetSelection list - New.treeSelectionSetMode sel SelectionSingle - mapM_ (\(str,func) -> do - col <- New.treeViewColumnNew - New.treeViewColumnSetTitle col str - New.treeViewColumnSetResizable col True - New.treeViewAppendColumn list col - renderer <- New.cellRendererTextNew - New.cellLayoutPackStart col renderer True - New.cellLayoutSetAttributes col renderer listStore func - ) columnsDD - New.treeViewSetHeadersVisible list showHeaders - sel `New.onSelectionChanged` (selectionHandler sel listStore injS) - boxPackStart box list PackNatural 0 - boxPackStart box buttonBox PackNatural 0 - boxPackEnd box frameS PackGrow 0 - activateEvent (castToWidget list) FocusOut notifier - containerAdd widget box - New.listStoreClear listStore - mapM_ (New.listStoreAppend listStore) v - addButton `onClicked` do - mbv <- extS - case mbv of - Just v -> do - New.listStoreAppend listStore v - return () - Nothing -> return () - removeButton `onClicked` do - mbi <- New.treeSelectionGetSelected sel - case mbi of - Nothing -> return () - Just iter -> do - [i] <- New.treeModelGetPath listStore iter - New.listStoreRemove listStore i - writeIORef coreRef (Just listStore) - injS getDefault - Just listStore -> do - New.listStoreClear listStore - mapM_ (New.listStoreAppend listStore) v) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just listStore -> do - v <- listStoreGetValues listStore - return (Just v)) - (mkNotifier notifier) - parameters - where - listStoreGetValues :: New.ListStore a -> IO [a] - listStoreGetValues listStore = do - mbi <- New.treeModelGetIterFirst listStore - getTail mbi - where getTail mbi = case mbi of - Nothing -> return [] - Just iter -> do - [i] <- New.treeModelGetPath listStore iter - v <- New.listStoreGetValue listStore i - mbi2 <- New.treeModelIterNext listStore iter - rest <- getTail mbi2 - return (v : rest) - selectionHandler :: New.TreeSelection -> New.ListStore a -> Injector a -> IO () - selectionHandler sel listStore inj = do - ts <- New.treeSelectionGetSelected sel - case ts of - Nothing -> return () - Just iter -> do - [i] <- New.treeModelGetPath listStore iter - v <- New.listStoreGetValue listStore i - inj v - return () - diff --git a/src/IDE/Framework/EditorBasics.hs b/src/IDE/Framework/EditorBasics.hs deleted file mode 100644 --- a/src/IDE/Framework/EditorBasics.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- --- Module : IDE.Framework.EditorBasics --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | Module for the basiscs of composing GUIs from editors --- ------------------------------------------------------------------------------------ - -module IDE.Framework.EditorBasics ( --- * Types - Getter -, Setter -, Injector -, Extractor -, Editor ---, Applicator -, Handler -, Notifier -, EventSelector(..) -) where - -import Graphics.UI.Gtk --hiding (Event) -import Data.Unique - -import Graphics.UI.Gtk --hiding (Event) - -import IDE.Framework.Parameters - --- --------------------------------------------------------------------- --- * Basic Types --- - --- --- | A type for getting a field of a record --- -type Getter alpha beta = alpha -> beta --- --- | A type for setting the field of a record --- -type Setter alpha beta = beta -> alpha -> alpha - --- --- | A type for injecting a value into an editor --- -type Injector beta = beta -> IO() --- --- | A type for extracting a value from an editor --- -type Extractor beta = IO(Maybe (beta)) - ---type Applicator beta = beta -> IDEAction () - ---class EventSource alpha where - ---class Event alpha where --- event :: a -> Event - --- --- | A type for handling an IO event --- Returning True: The event has been handles --- Returning False: Handling should proceed -type Handler = Event -> IO Bool - -data EventSelector = Clicked - | FocusOut - | FocusIn - | SelectionChanged - | ButtonRelease - deriving (Eq,Ord,Show) - --- --- | A type to register or unregister a handler --- If the second argument is Left Handler the handler gets registered --- If the second argument is Right Unique the handler will be removed --- The returned unique value must be used for unregistering an event -type Notifier = EventSelector -> Either Handler Unique -> IO (Unique) - --- --- | A type to describe an editor. --- alpha is the type of the individual field of the record -type Editor alpha = Parameters -> IO(Widget, Injector alpha , Extractor alpha , Notifier) - - diff --git a/src/IDE/Framework/MakeEditor.hs b/src/IDE/Framework/MakeEditor.hs deleted file mode 100644 --- a/src/IDE/Framework/MakeEditor.hs +++ /dev/null @@ -1,265 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : IDE.Framework.MakeEditor --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | Module for making editors out of descriptions --- ------------------------------------------------------------------------------------ - -module IDE.Framework.MakeEditor ( - - FieldDescription(..) -, mkField -, emptyNotifier -, EventSelector(..) -, extractAndValidate -, extract -, mkEditor - -, declareEvent -, activateEvent -, propagateEvent -, mkNotifier - -) where - -import Graphics.UI.Gtk hiding (Event) -import Control.Monad -import Data.IORef -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Unique - -import IDE.Core.Exception -import IDE.Framework.Parameters -import IDE.Framework.EditorBasics - --- --- | A constructor type for a field desciption --- -type MkFieldDescription alpha beta = - Parameters -> - (Getter alpha beta) -> - (Setter alpha beta) -> - (Editor beta) -> - FieldDescription alpha - --- --- | A type to describe a field of a record, which can be edited --- | alpha is the type of the individual field of the record -data FieldDescription alpha = FD { - parameters :: Parameters - , fieldEditor :: alpha -> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier) - } - --- ------------------------------------------------------------ --- * Implementation of editing --- ------------------------------------------------------------ - --- --- | Function to construct a field description --- -mkField :: Eq beta => MkFieldDescription alpha beta -mkField parameters getter setter editor = - FD parameters - (\ dat -> do - (widget, inj,ext,noti) <- editor parameters - inj (getter dat) - noti FocusOut (Left (\e -> do - v <- ext - case v of - Just _ -> do - return False - Nothing -> do - sysMessage Normal "Validation Failure" - let message = case getParameterPrim paraName parameters of - Just s -> "in field " ++ s - Nothing -> "in unnamed field" - dia <- messageDialogNew Nothing [] MessageWarning ButtonsClose - ("Validation Failure " ++ message) - dialogRun dia - widgetDestroy dia - return False)) - return (widget, - (\a -> inj (getter a)), - (\a -> do - b <- ext - case b of - Just b -> return (Just (setter b a)) - Nothing -> return Nothing), - noti)) - --- | Function to construct an editor --- -mkEditor :: (Container -> Injector alpha) -> Extractor alpha -> Notifier -> Editor alpha -mkEditor injectorC extractor notifier parameters = do - let (xalign, yalign, xscale, yscale) = getParameter paraOuterAlignment parameters - outerAlig <- alignmentNew xalign yalign xscale yscale - let (paddingTop, paddingBottom, paddingLeft, paddingRight) = getParameter paraOuterPadding parameters - alignmentSetPadding outerAlig paddingTop paddingBottom paddingLeft paddingRight - frame <- frameNew - frameSetShadowType frame (getParameter paraShadow parameters) - case getParameter paraName parameters of - "" -> return () - str -> frameSetLabel frame str - containerAdd outerAlig frame - let (xalign, yalign, xscale, yscale) = getParameter paraInnerAlignment parameters - innerAlig <- alignmentNew xalign yalign xscale yscale - let (paddingTop, paddingBottom, paddingLeft, paddingRight) = getParameter paraInnerPadding parameters - alignmentSetPadding innerAlig paddingTop paddingBottom paddingLeft paddingRight - containerAdd frame innerAlig - let (x,y) = getParameter paraMinSize parameters - widgetSetSizeRequest outerAlig x y - return ((castToWidget) outerAlig, injectorC (castToContainer innerAlig), extractor, notifier) - --- | Convenience method to validate and extract fields --- -extractAndValidate :: alpha -> [alpha -> Extractor alpha] -> [String] -> IO (Maybe alpha) -extractAndValidate val getExts fieldNames = do - (newVal,errors) <- foldM (\ (val,errs) (ext,fn) -> do - extVal <- ext val - case extVal of - Just nval -> return (nval,errs) - Nothing -> return (val, (' ' : fn) : errs)) - (val,[]) (zip getExts fieldNames) - if null errors - then return (Just newVal) - else do - md <- messageDialogNew Nothing [] MessageWarning ButtonsClose - $ "The following fields have invalid values." ++ - concat (reverse errors) - dialogRun md - widgetDestroy md - return Nothing - -extract :: alpha -> [alpha -> Extractor alpha] -> IO (Maybe alpha) -extract val getExts = - foldM (\ mbVal ext -> do - case mbVal of - Nothing -> return Nothing - Just val -> do - newVal <- ext val - return newVal) - (Just val) getExts - --- ------------------------------------------------------------ --- * Implementation of notifications --- ------------------------------------------------------------ - --- --- | A type for a function to register an event --- -type RegFunc = Widget -> Handler -> IO (ConnectId Widget) - --- --- | A type for the state of the notification system --- -type NotifierSt = IORef (Map EventSelector - (Maybe Widget,RegFunc,Maybe (ConnectId Widget),[(Unique, Handler)])) - --- --- | Initial state of the notification system --- -emptyNotifier :: IO (NotifierSt) -emptyNotifier = newIORef(Map.empty) - --- --- | Declare that the event can be thrown from this editor --- -declareEvent :: EventSelector -> RegFunc -> NotifierSt -> IO() -declareEvent eventSel regFunc notifierState = do - noti <- readIORef notifierState - case Map.lookup eventSel noti of - Nothing -> do - let noti2 = Map.insert eventSel (Nothing, regFunc, Nothing,[]) noti - writeIORef notifierState noti2 - Just _ -> throwIDE $"editor has already declared event " ++ show eventSel - --- --- | Activate the event after the widget has been constructed --- -activateEvent :: Widget -> EventSelector -> NotifierSt -> IO() -activateEvent widget eventSel notifierState = do - noti <- readIORef notifierState - case Map.lookup eventSel noti of - Nothing -> throwIDE $"editor has not declared event before activating it " ++ show eventSel - Just (Nothing,registerFunc,Nothing,handlers) -> do - cid <- registerFunc widget (\ e -> do - noti <- readIORef notifierState - case Map.lookup eventSel noti of - Nothing -> return False - Just (_,_,_,[]) -> return False - Just (_,_,_,handlers2) -> do - boolList <- mapM (\f -> f e) (map snd handlers2) - return (foldl (&&) True boolList)) - let noti2 = Map.insert eventSel (Just widget,registerFunc,Just cid,handlers) noti - writeIORef notifierState noti2 - Just _ -> throwIDE $"editor has already been activated " ++ show eventSel - --- --- | Propagate the event with the selector from notifier to notifierst --- -propagateEvent :: EventSelector -> Notifier -> NotifierSt -> IO() -propagateEvent eventSel notiFrom notifierState = do - noti <- readIORef notifierState - case Map.lookup eventSel noti of - Nothing -> throwIDE $"can't propagte event which is not activated " ++ show eventSel - Just (mbWidget,registerFunc,Nothing,handlers) -> do - cid <- notiFrom eventSel (Left (\ e -> do - noti <- readIORef notifierState - case Map.lookup eventSel noti of - Nothing -> return False - Just (_,_,_,[]) -> return False - Just (_,_,_,handlers2) -> do - boolList <- mapM (\f -> f e) (map snd handlers2) - return (foldl (&&) True boolList))) - let noti2 = Map.insert eventSel (mbWidget,registerFunc,Nothing,handlers) noti - writeIORef notifierState noti2 - Just _ -> throwIDE $"editor has already been activated " ++ show eventSel - --- --- | Constructor for a notifier --- -mkNotifier :: NotifierSt -> Notifier -mkNotifier notifierState = notFunc - where - notFunc :: EventSelector -> Either Handler Unique -> IO (Unique) - notFunc eventSel (Left handler) = do - noti <- readIORef notifierState - uni <- newUnique - case Map.lookup eventSel noti of - Nothing -> throwIDE $"editor does not support event " ++ show eventSel - Just (Just widget,registerFunc,Nothing,handlers) - -> throwIDE $"mkNotifier for activated event" ++ show eventSel - Just (mbWidget, registerFunc, mbUnique, handlers) - -> do unique <- newUnique - let noti2 = Map.insert eventSel - (mbWidget,registerFunc,mbUnique,handlers++[(uni,handler)]) noti - writeIORef notifierState noti2 - return unique - notFunc eventSel (Right uni) = do - noti <- readIORef notifierState - case Map.lookup eventSel noti of - Nothing -> throwIDE $"editor does not support event " ++ show eventSel - Just (mbWidget,regFunc,Just cid,l) -> do - let l2 = filter (\(u,_) -> u /= uni) l - if null l2 - then do - signalDisconnect cid - let noti2 = Map.insert eventSel (mbWidget,regFunc,Nothing,[]) noti - writeIORef notifierState noti2 - else do - let noti2 = Map.insert eventSel (mbWidget,regFunc,Just cid,l2) noti - writeIORef notifierState noti2 - _ -> return () - return uni - - - - diff --git a/src/IDE/Framework/Parameters.hs b/src/IDE/Framework/Parameters.hs deleted file mode 100644 --- a/src/IDE/Framework/Parameters.hs +++ /dev/null @@ -1,148 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : IDE.Framework.Parameters --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | Module for parameters for editors --- ------------------------------------------------------------------------------------ - -module IDE.Framework.Parameters ( - Parameters -, Parameter(..) -, paraName -, paraSynopsis -, paraDirection -, paraShadow -, paraOuterAlignment -, paraInnerAlignment -, paraOuterPadding -, paraInnerPadding -, paraMinSize -, paraHorizontal -, getParameter -, getParameterPrim -, (<<<-) -, emptyParams -, Direction(..) -, HorizontalAlign(..) -) where - -import Graphics.UI.Gtk -import Data.Maybe -import qualified Data.List as List - -import IDE.Core.Exception - --- --- | The direction of a split --- -data Direction = Horizontal | Vertical - deriving (Eq,Show) - -data HorizontalAlign = StartHorizontal | StopHorizontal | Keep - deriving (Eq,Show) --- --- | A type for parameters for editors --- -type Parameters = [Parameter] - -data Parameter = ParaName String - | ParaSynopsis String - | ParaDirection Direction - | ParaShadow ShadowType - | ParaOuterAlignment (Float,Float,Float,Float) - -- | xalign yalign xscale yscale - | ParaOuterPadding (Int,Int,Int,Int) - -- | paddingTop paddingBottom paddingLeft paddingRight - | ParaInnerAlignment (Float,Float,Float,Float) - -- | xalign yalign xscale yscale - | ParaInnerPadding (Int,Int,Int,Int) - -- | paddingTop paddingBottom paddingLeft paddingRight - | ParaMinSize (Int, Int) - | ParaHorizontal HorizontalAlign - deriving (Eq,Show) - -instance Show ShadowType - where show _ = "Any Shadow" - -emptyParams :: [Parameter] -emptyParams = [] - -paraName :: (Parameter -> (Maybe String)) -paraName (ParaName str) = Just str -paraName _ = Nothing - -paraSynopsis :: (Parameter -> (Maybe String)) -paraSynopsis (ParaSynopsis str) = Just str -paraSynopsis _ = Nothing - -paraDirection :: (Parameter -> (Maybe Direction)) -paraDirection (ParaDirection d) = Just d -paraDirection _ = Nothing - -paraShadow :: (Parameter -> (Maybe ShadowType)) -paraShadow (ParaShadow d) = Just d -paraShadow _ = Nothing - -paraOuterAlignment :: (Parameter -> (Maybe (Float,Float,Float,Float))) -paraOuterAlignment (ParaOuterAlignment d) = Just d -paraOuterAlignment _ = Nothing - -paraInnerAlignment :: (Parameter -> (Maybe (Float,Float,Float,Float))) -paraInnerAlignment (ParaInnerAlignment d) = Just d -paraInnerAlignment _ = Nothing - -paraOuterPadding :: (Parameter -> (Maybe (Int,Int,Int,Int))) -paraOuterPadding (ParaOuterPadding d) = Just d -paraOuterPadding _ = Nothing - -paraInnerPadding :: (Parameter -> (Maybe (Int,Int,Int,Int))) -paraInnerPadding (ParaInnerPadding d) = Just d -paraInnerPadding _ = Nothing - -paraMinSize :: (Parameter -> (Maybe (Int, Int))) -paraMinSize (ParaMinSize d) = Just d -paraMinSize _ = Nothing - -paraHorizontal :: (Parameter -> (Maybe (HorizontalAlign))) -paraHorizontal (ParaHorizontal d) = Just d -paraHorizontal _ = Nothing - --- --- | Convenience method to get a parameter, or if not set the default parameter --- -getParameter :: (Parameter -> (Maybe beta)) -> Parameters -> beta -getParameter selector parameter = - case getParameterPrim selector parameter of - Just ele -> ele - _ -> case getParameterPrim selector defaultParameters of - Just ele -> ele - _ -> throwIDE "default parameter not defined" - -getParameterPrim :: (Parameter -> (Maybe beta)) -> Parameters -> Maybe beta -getParameterPrim selector parameter = - case filter isJust $ map selector parameter of - (Just ele) : _ -> Just ele - _ -> Nothing - -(<<<-) :: (Parameter -> (Maybe beta)) -> Parameter -> Parameters -> Parameters -(<<<-) selector para = \params -> para : filter (isNothing . selector) params - -defaultParameters :: Parameters -defaultParameters = - [ ParaName "" - , ParaSynopsis "" - , ParaDirection Horizontal - , ParaShadow ShadowNone - , ParaOuterAlignment (0.5, 0.5, 0.95, 0.95) - , ParaOuterPadding (2, 5, 3, 3) - , ParaInnerAlignment (0.5, 0.5, 0.95, 0.95) - , ParaInnerPadding (2, 5, 3, 3) - , ParaMinSize (-1,-1) - , ParaHorizontal Keep] diff --git a/src/IDE/Framework/SimpleEditors.hs b/src/IDE/Framework/SimpleEditors.hs deleted file mode 100644 --- a/src/IDE/Framework/SimpleEditors.hs +++ /dev/null @@ -1,561 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : IDE.Framework.SimpleEditors --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | Module for making simple editors --- ------------------------------------------------------------------------------------ - -module IDE.Framework.SimpleEditors ( - boolEditor -, boolEditor2 -, stringEditor -, multilineStringEditor -, intEditor -, genericEditor -, fontEditor -, staticSelectionEditor -, staticMultiselectionEditor -, multiselectionEditor -, fileEditor -, otherEditor -) where - -import Graphics.UI.Gtk -import Graphics.UI.Gtk.ModelView as New -import Control.Monad -import Data.IORef -import Data.List -import Data.Maybe -import System.FilePath.Posix - -import IDE.Framework.Parameters -import IDE.Framework.EditorBasics -import IDE.Framework.MakeEditor -import IDE.Core.Exception - --- ------------------------------------------------------------ --- * Simple Editors --- ------------------------------------------------------------ - -instance ContainerClass Widget -instance BinClass Widget -instance ButtonClass Widget - --- --- | Editor for a boolean value in the form of a check button --- -boolEditor :: Editor Bool -boolEditor parameters = do - coreRef <- newIORef Nothing - notifier <- emptyNotifier - declareEvent Clicked (\w h -> w `onClicked` do h (Event True); return ()) notifier - declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier - mkEditor - (\widget bool -> do - core <- readIORef coreRef - case core of - Nothing -> do - button <- checkButtonNewWithLabel (getParameter paraName parameters) - containerAdd widget button - toggleButtonSetActive button bool - activateEvent (castToWidget button) Clicked notifier - activateEvent (castToWidget button) FocusOut notifier - writeIORef coreRef (Just button) - Just button -> toggleButtonSetActive button bool) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just button -> do - r <- toggleButtonGetActive button - return (Just r)) - (mkNotifier notifier) - (paraName <<<- (ParaName "") $ parameters) - --- --- | Editor for a boolean value in the form of two radio buttons --- -boolEditor2 :: String -> Editor Bool -boolEditor2 label2 parameters = do - coreRef <- newIORef Nothing - notifier <- emptyNotifier - declareEvent Clicked (\w h -> w `onClicked` do h (Event True); return ()) notifier - declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier - mkEditor - (\widget bool -> do - core <- readIORef coreRef - case core of - Nothing -> do - box <- vBoxNew True 2 - radio1 <- radioButtonNewWithLabel (getParameter paraName parameters) - radio2 <- radioButtonNewWithLabelFromWidget radio1 label2 - boxPackStart box radio1 PackGrow 2 - boxPackStart box radio2 PackGrow 2 - containerAdd widget box - if bool - then do - toggleButtonSetActive radio1 True - else do - toggleButtonSetActive radio2 True - activateEvent (castToWidget radio1) Clicked notifier - activateEvent (castToWidget radio1) FocusOut notifier - writeIORef coreRef (Just (radio1,radio2)) - Just (radio1,radio2) -> - if bool - then do - toggleButtonSetActive radio1 True - else do - toggleButtonSetActive radio2 True) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just (radio1,radio2) -> do - r <- toggleButtonGetActive radio1 - return (Just r)) - (mkNotifier notifier) - (paraName <<<- (ParaName "") $ parameters) - --- --- | Editor for a string in the form of a text entry --- -stringEditor :: Editor String -stringEditor parameters = do - coreRef <- newIORef Nothing - notifier <- emptyNotifier - declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier - mkEditor - (\widget string -> do - core <- readIORef coreRef - case core of - Nothing -> do - entry <- entryNew - activateEvent (castToWidget entry) FocusOut notifier - containerAdd widget entry - entrySetText entry string - writeIORef coreRef (Just entry) - Just entry -> entrySetText entry string) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just entry -> do - r <- entryGetText entry - return (Just r)) - (mkNotifier notifier) - parameters - --- --- | Editor for a multiline string in the form of a multiline text entry --- -multilineStringEditor :: Editor String -multilineStringEditor parameters = do - coreRef <- newIORef Nothing - notifier <- emptyNotifier - declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier - declareEvent ButtonRelease (\w h -> w `onButtonRelease` h) notifier - mkEditor - (\widget string -> do - core <- readIORef coreRef - case core of - Nothing -> do - aTextView <- textViewNew - aScrolledWindow <- scrolledWindowNew Nothing Nothing - scrolledWindowSetPolicy aScrolledWindow PolicyAutomatic PolicyAutomatic - containerAdd aScrolledWindow aTextView - containerAdd widget aScrolledWindow - activateEvent (castToWidget aTextView) FocusOut notifier - activateEvent (castToWidget aTextView) ButtonRelease notifier - buffer <- textViewGetBuffer aTextView - textBufferSetText buffer string - writeIORef coreRef (Just (aScrolledWindow,aTextView)) - Just (aScrolledWindow,aTextView) -> do - buffer <- textViewGetBuffer aTextView - textBufferSetText buffer string) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just (aScrolledWindow, aTextView) -> do - buffer <- textViewGetBuffer aTextView - start <- textBufferGetStartIter buffer - end <- textBufferGetEndIter buffer - r <- textBufferGetText buffer start end False - return (Just r)) - (mkNotifier notifier) - parameters - --- --- | Editor for an integer in the form of a spin entry --- -intEditor :: (Double,Double,Double) -> Editor Int -intEditor (min, max, step) parameters = do - coreRef <- newIORef Nothing - notifier <- emptyNotifier - declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier - mkEditor - (\widget v -> do - core <- readIORef coreRef - case core of - Nothing -> do - spin <- spinButtonNewWithRange min max step - activateEvent (castToWidget spin) FocusOut notifier - containerAdd widget spin - spinButtonSetValue spin (fromIntegral v) - writeIORef coreRef (Just spin) - Just spin -> spinButtonSetValue spin (fromIntegral v)) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just spin -> do - newNum <- spinButtonGetValue spin - return (Just (truncate newNum))) - (mkNotifier notifier) - parameters - --- --- | Editor for for any value which is an instance of Read and Show in the form of a --- | text entry -genericEditor :: (Show beta, Read beta) => Editor beta -genericEditor parameters = do - (wid,inj,ext,notif) <- stringEditor parameters - let ginj v = inj (show v) - let gext = do - s <- ext - case s of - Nothing -> return Nothing - Just s -> - let l = read s in - if null l then - return Nothing - else return (Just (head l)) - return (wid,ginj,gext,notif) - -#ifdef False --- --- | Editor for the selection of an element from a static list of elements in the --- | form of a combo box -staticSelectionEditor :: (Show beta, Eq beta) => [beta] -> Editor beta -staticSelectionEditor list parameters = do - coreRef <- newIORef Nothing - notifier <- emptyNotifier - declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier - mkEditor - (\widget obj -> do - core <- readIORef coreRef - case core of - Nothing -> do - (combo,_) <- New.comboBoxNewText show list - activateEvent (castToWidget combo) FocusOut notifier - New.comboBoxSetActive combo 1 - containerAdd widget combo - let ind = elemIndex obj list - case ind of - Just i -> New.comboBoxSetActive combo i - Nothing -> return () - writeIORef coreRef (Just combo) - Just combo -> do - let ind = elemIndex obj list - case ind of - Just i -> New.comboBoxSetActive combo i - Nothing -> return ()) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just combo -> do - ind <- New.comboBoxGetActive combo - case ind of - i | i >= 0 -> return (Just (list !! i)) - otherwise -> return Nothing) - (mkNotifier notifier) - parameters - -#else -staticSelectionEditor :: (Show beta, Eq beta) => [beta] -> Editor beta -staticSelectionEditor list parameters = do - coreRef <- newIORef Nothing - notifier <- emptyNotifier - declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier - mkEditor - (\widget obj -> do - core <- readIORef coreRef - case core of - Nothing -> do - combo <- New.comboBoxNewText - activateEvent (castToWidget combo) FocusOut notifier - New.comboBoxSetActive combo 1 - containerAdd widget combo - mapM_ (\t -> New.comboBoxAppendText combo (show t)) list - let ind = elemIndex obj list - case ind of - Just i -> New.comboBoxSetActive combo i - Nothing -> return () - writeIORef coreRef (Just combo) - Just combo -> do - let ind = elemIndex obj list - case ind of - Just i -> New.comboBoxSetActive combo i - Nothing -> return ()) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just combo -> do - mbInd <- New.comboBoxGetActive combo - case mbInd of - Just i -> return (Just (list !! i)) - otherwise -> return Nothing) - (mkNotifier notifier) - parameters -#endif - - --- --- | Editor for the selection of some elements from a static list of elements in the --- | form of a list box - -multiselectionEditor :: (Show beta, Eq beta) => Editor [beta] -multiselectionEditor parameters = do - coreRef <- newIORef Nothing - notifier <- emptyNotifier - declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier - mkEditor - (\widget objs -> do - core <- readIORef coreRef - case core of - Nothing -> do - listStore <- New.listStoreNew ([]:: [alpha]) - listView <- New.treeViewNewWithModel listStore - activateEvent (castToWidget listView) FocusOut notifier - sel <- New.treeViewGetSelection listView - New.treeSelectionSetMode sel SelectionMultiple - renderer <- New.cellRendererTextNew - col <- New.treeViewColumnNew - New.treeViewAppendColumn listView col - New.cellLayoutPackStart col renderer True - New.cellLayoutSetAttributes col renderer listStore $ \row -> [ New.cellText := show row ] - New.treeViewSetHeadersVisible listView False - New.listStoreClear listStore - mapM_ (New.listStoreAppend listStore) objs - containerAdd widget listView - New.treeSelectionUnselectAll sel - --let inds = catMaybes $map (\obj -> elemIndex obj list) objs - --mapM_ (\i -> New.treeSelectionSelectPath sel [i]) inds - writeIORef coreRef (Just (listView,listStore)) - Just (listView,listStore) -> do - New.listStoreClear listStore - mapM_ (New.listStoreAppend listStore) objs) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just (listView,listStore) -> do - sel <- New.treeViewGetSelection listView - treePath <- New.treeSelectionGetSelectedRows sel - values <- mapM (\[i] -> listStoreGetValue listStore i) treePath - return (Just values)) - (mkNotifier notifier) - parameters - --- --- | Editor for the selection of some elements from a static list of elements in the --- | form of a list box - -staticMultiselectionEditor :: (Show beta, Eq beta) => [beta] -> Editor [beta] -staticMultiselectionEditor list parameters = do - coreRef <- newIORef Nothing - notifier <- emptyNotifier - declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier - mkEditor - (\widget objs -> do - core <- readIORef coreRef - case core of - Nothing -> do - listStore <- New.listStoreNew ([]:: [alpha]) - listView <- New.treeViewNewWithModel listStore - activateEvent (castToWidget listView) FocusOut notifier - sel <- New.treeViewGetSelection listView - New.treeSelectionSetMode sel SelectionMultiple - renderer <- New.cellRendererTextNew - col <- New.treeViewColumnNew - New.treeViewAppendColumn listView col - New.cellLayoutPackStart col renderer True - New.cellLayoutSetAttributes col renderer listStore $ \row -> [ New.cellText := show row ] - New.treeViewSetHeadersVisible listView False - New.listStoreClear listStore - mapM_ (New.listStoreAppend listStore) list - containerAdd widget listView - New.treeSelectionUnselectAll sel - let inds = catMaybes $map (\obj -> elemIndex obj list) objs - mapM_ (\i -> New.treeSelectionSelectPath sel [i]) inds - writeIORef coreRef (Just listView) - Just listView -> do - sel <- New.treeViewGetSelection listView - New.treeSelectionUnselectAll sel - let inds = catMaybes $map (\obj -> elemIndex obj list) objs - mapM_ (\i -> New.treeSelectionSelectPath sel [i]) inds) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just listView -> do - sel <- New.treeViewGetSelection listView - treePath <- New.treeSelectionGetSelectedRows sel - return (Just (map (\[i] -> list !! i) treePath))) - (mkNotifier notifier) - parameters - --- --- | Editor for the selection of a file path in the form of a text entry and a button, --- | which opens a gtk file chooser -fileEditor :: Maybe FilePath -> FileChooserAction -> String -> Editor FilePath -fileEditor mbFilePath action buttonName parameters = do - coreRef <- newIORef Nothing - notifier <- emptyNotifier - declareEvent Clicked - (\widget handler -> do widget `onClicked` do - handler (Event True) - return ()) notifier - declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier - mkEditor - (\widget filePath -> do - core <- readIORef coreRef - case core of - Nothing -> do - button <- buttonNewWithLabel buttonName - entry <- entryNew - set entry [ entryEditable := False ] - activateEvent (castToWidget button) Clicked notifier - (mkNotifier notifier) Clicked (Left (buttonHandler entry)) - box <- case getParameter paraDirection parameters of - Horizontal -> do - r <- hBoxNew False 1 - return (castToBox r) - Vertical -> do - r <- vBoxNew False 1 - return (castToBox r) - activateEvent (castToWidget button) FocusOut notifier - boxPackStart box entry PackGrow 0 - boxPackEnd box button PackNatural 0 - containerAdd widget box - entrySetText entry filePath - writeIORef coreRef (Just entry) - Just entry -> entrySetText entry filePath) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just entry -> do - str <- entryGetText entry - return (Just str)) - (mkNotifier notifier) - parameters - where - buttonHandler entry = (\ e -> do - mbFileName <- do - dialog <- fileChooserDialogNew - (Just $ "Select File") - Nothing - action - [("gtk-cancel" - ,ResponseCancel) - ,("gtk-open" - ,ResponseAccept)] - widgetShow dialog - response <- dialogRun dialog - case response of - ResponseAccept -> do - f <- fileChooserGetFilename dialog - widgetDestroy dialog - return f - ResponseCancel -> do - widgetDestroy dialog - return Nothing - ResponseDeleteEvent-> do - widgetDestroy dialog - return Nothing - _ -> return Nothing - case mbFileName of - Nothing -> return True - Just fn -> do - let relative = case mbFilePath of - Nothing -> fn - Just rel -> makeRelative rel fn - entrySetText entry relative - return True) - --- --- | Editor for a font selection --- -fontEditor :: Editor (Maybe String) -fontEditor parameters = do - coreRef <- newIORef Nothing - notifier <- emptyNotifier - declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier - mkEditor - (\widget mbValue -> do - core <- readIORef coreRef - case core of - Nothing -> do - fs <- fontButtonNew - activateEvent (castToWidget fs) FocusOut notifier - containerAdd widget fs - case mbValue of - Nothing -> return True - Just s -> fontButtonSetFontName fs s - writeIORef coreRef (Just fs) - Just fs -> case mbValue of - Nothing -> return () - Just s -> do - fontButtonSetFontName fs s - return ()) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just fs -> do - f <- fontButtonGetFontName fs - return (Just (Just f))) - (mkNotifier notifier) - parameters - --- --- | An editor, which opens another editor --- You have to inject a value before the button can be clicked. --- -otherEditor :: (alpha -> String -> IO (Maybe alpha)) -> Editor alpha -otherEditor func parameters = do - coreRef <- newIORef Nothing - notifier <- emptyNotifier - declareEvent Clicked (\w h -> w `onClicked` do h (Event True); return ()) notifier - declareEvent FocusIn (\w h -> w `onFocusIn` do h) notifier - declareEvent FocusOut (\w h -> w `onFocusOut` do h) notifier - mkEditor - (\widget val -> do - core <- readIORef coreRef - case core of - Nothing -> do - button <- buttonNewWithLabel (getParameter paraName parameters) - containerAdd widget button - activateEvent (castToWidget button) Clicked notifier - activateEvent (castToWidget button) FocusIn notifier - activateEvent (castToWidget button) FocusOut notifier - (mkNotifier notifier) Clicked (Left (buttonHandler coreRef)) - writeIORef coreRef (Just (button,val)) - Just (button, oldval) -> writeIORef coreRef (Just (button, val))) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just (_,val) -> return (Just val)) - (mkNotifier notifier) - (paraName <<<- (ParaName "") $ parameters) - where - buttonHandler coreRef = (\ e -> do - core <- readIORef coreRef - case core of - Nothing -> throwIDE "You have to inject a value before the button can be clicked" - Just (b,val) -> do - res <- func val (getParameter paraName parameters) - case res of - Nothing -> return True - Just nval -> do - writeIORef coreRef (Just (b, nval)) - return True) diff --git a/src/IDE/Framework/ViewFrame.hs b/src/IDE/Framework/ViewFrame.hs deleted file mode 100644 --- a/src/IDE/Framework/ViewFrame.hs +++ /dev/null @@ -1,697 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : IDE.Framework.ViewFrame --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- --- | Splittable panes containing notebooks with any widgets --- ---------------------------------------------------------------------------------- - -module IDE.Framework.ViewFrame ( - removePaneAdmin -, addPaneAdmin -, notebookInsertOrdered - --- * Convenience methods for accesing Pane state -, posTypeToPaneDirection -, paneDirectionToPosType -, paneFromName -, mbPaneFromName -, guiPropertiesFromName - --- * View Actions -, viewMove -, viewSplitHorizontal -, viewSplitVertical -, viewSplit -, viewSplit' -, viewCollapse -, viewTabsPos -, viewSwitchTabs - --- * View Queries -, getStandardPanePath -, getActivePanePath -, getActivePanePathOrStandard -, figureOutPaneName -, getNotebook -, getPaned -, getActiveNotebook -, getPane -, getPanes - --- * View Actions -, bringPaneToFront -, newNotebook -, activatePane -, deactivatePane -, deactivatePaneIfActive - --- * Accessing GUI elements -, widgetFromPath -, getCandyState -, setCandyState - -, getSBSpecialKeys -, getSBActivePane -, getSBActivePackage -, getSBErrors -, getStatusbarIO -, getStatusbarLC - -) where - -import Graphics.UI.Gtk hiding (afterToggleOverwrite,onToggleOverwrite) -import Control.Monad.Reader -import qualified Data.Map as Map -import Data.Map (Map) -import Data.List -import Data.Maybe -import GHC.Exception(evaluate,catch) - -import IDE.Core.State -import IDE.Core.Types -import IDE.Core.Panes -import IDE.Framework.Parameters - -removePaneAdmin :: (CastablePane alpha,RecoverablePane alpha beta) => alpha -> IDEAction -removePaneAdmin pane = do - panes' <- readIDE panes - paneMap' <- readIDE paneMap - let newPanes = Map.delete (paneName pane) panes' - let newPaneMap = Map.delete (paneName pane) paneMap' - modifyIDE_ (\ide -> return (ide{panes = newPanes, paneMap = newPaneMap})) - -addPaneAdmin :: (CastablePane alpha,RecoverablePane alpha beta) => alpha -> Connections -> PanePath -> IDEAction -addPaneAdmin pane conn pp = do - panes' <- readIDE panes - paneMap' <- readIDE paneMap - let newPaneMap = Map.insert (paneName pane) (pp, conn) paneMap' - let newPanes = Map.insert (paneName pane) (PaneC pane) panes' - modifyIDE_ (\ide -> return (ide{panes = newPanes, - paneMap = newPaneMap})) - - -notebookInsertOrdered :: (NotebookClass self, WidgetClass child) - => self - -> child -- child - the Widget to use as the contents of the page. - -> String -- tabLabel - the label for the page - -> IO () -notebookInsertOrdered nb widget label = do - numPages <- notebookGetNPages nb - mbWidgets <- mapM (notebookGetNthPage nb) [0 .. (numPages-1)] - widgets <- catch (evaluate (map fromJust mbWidgets)) - (\e -> throwIDE "ViewFrame.notebookInsertOrdered: no widget") - mbLabels <- mapM (notebookGetTabLabelText nb) widgets - labels <- catch (evaluate (map fromJust mbLabels)) - (\e -> throwIDE "ViewFrame.notebookInsertOrdered: no label") - let pos = case findIndex (\s -> s > label) labels of - Just i -> i - Nothing -> -1 - realPos <- notebookInsertPage nb widget label pos - notebookSetCurrentPage nb realPos -getPane :: CastablePane alpha => Casting alpha -> IDEM (Maybe alpha) -getPane casting = do - selectedPanes <- getPanes casting - if null selectedPanes || length selectedPanes > 1 - then return Nothing - else (return (Just $head selectedPanes)) - -getPanes :: CastablePane alpha => Casting alpha -> IDEM ([alpha]) -getPanes casting = do - panes' <- readIDE panes - return (catMaybes $ map (downCast casting) $ Map.elems panes') - --- | Constructs a unique pane name, which is an index and a string -figureOutPaneName :: Pane alpha => Map String alpha -> String -> Int -> (Int,String) -figureOutPaneName bufs bn ind = - let ind = foldr (\buf ind -> - if primPaneName buf == bn - then max ind ((getAddedIndex buf) + 1) - else ind) - 0 (Map.elems bufs) - in if ind == 0 - then (0,bn) - else (ind,bn ++ "(" ++ show ind ++ ")") - -paneFromName :: PaneName -> IDEM IDEPane -paneFromName pn = do - mbPane <- mbPaneFromName pn - case mbPane of - Just p -> return p - Nothing -> throwIDE $"Cant't find pane from unique name " ++ pn - -mbPaneFromName :: PaneName -> IDEM (Maybe IDEPane) -mbPaneFromName pn = do - panes <- readIDE panes - return (Map.lookup pn panes) - --- | -guiPropertiesFromName :: PaneName -> IDEM (PanePath, Connections) -guiPropertiesFromName pn = do - paneMap <- readIDE paneMap - case Map.lookup pn paneMap of - Just it -> return it - otherwise -> throwIDE $"Cant't find guiProperties from unique name " ++ pn - -posTypeToPaneDirection PosLeft = LeftP -posTypeToPaneDirection PosRight = RightP -posTypeToPaneDirection PosTop = TopP -posTypeToPaneDirection PosBottom = BottomP - -paneDirectionToPosType LeftP = PosLeft -paneDirectionToPosType RightP = PosRight -paneDirectionToPosType TopP = PosTop -paneDirectionToPosType BottomP = PosBottom - -activatePane :: Pane alpha => alpha -> Connections -> IDEAction -activatePane pane conn = do - deactivatePane - sb <- getSBActivePane - lift $statusbarPop sb 1 - lift $statusbarPush sb 1 (paneName pane) - modifyIDE_ $ \ide -> do - bringPaneToFront pane - return (ide{activePane = Just (paneName pane,conn)}) - -deactivatePane :: IDEAction -deactivatePane = do - sb <- getSBActivePane - lift $statusbarPop sb 1 - lift $statusbarPush sb 1 "" - mbAP <- readIDE activePane - case mbAP of - Just (_,BufConnections signals signals2 signals3) -> lift $do - mapM_ signalDisconnect signals - mapM_ signalDisconnect signals2 - mapM_ signalDisconnect signals3 - Nothing -> return () - modifyIDE_ $ \ide -> do - return (ide{activePane = Nothing}) - -deactivatePaneIfActive :: Pane alpha => alpha -> IDEAction -deactivatePaneIfActive pane = do - mbActive <- readIDE activePane - case mbActive of - Nothing -> return () - Just (n,_) -> if n == paneName pane - then deactivatePane - else return () --- --- | Toggle the tabs of the current notebook --- -viewSwitchTabs :: IDEAction -viewSwitchTabs = do - mbNb <- getActiveNotebook - case mbNb of - Nothing -> return () - Just nb -> lift $do - b <- notebookGetShowTabs nb - notebookSetShowTabs nb (not b) - --- --- | Sets the tab position in the current notebook --- -viewTabsPos :: PositionType -> IDEAction -viewTabsPos pos = do - mbNb <- getActiveNotebook - case mbNb of - Nothing -> return () - Just nb -> lift $notebookSetTabPos nb pos - --- --- | Split the currently active pane in horizontal direction --- -viewSplitHorizontal :: IDEAction -viewSplitHorizontal = viewSplit Horizontal - --- --- | Split the currently active pane in vertical direction --- -viewSplitVertical :: IDEAction -viewSplitVertical = viewSplit Vertical - --- --- | The active view can be split in two (horizontal or vertical) --- -viewSplit :: Direction -> IDEAction -viewSplit dir = do - mbPanePath <- getActivePanePath - case mbPanePath of - Nothing -> return () - Just panePath -> viewSplit' panePath dir - -viewSplit' :: PanePath -> Direction -> IDEAction -viewSplit' panePath dir = do - activeNotebook <- getNotebook panePath - mbPD <- lift $ do - mbParent <- widgetGetParent activeNotebook - case mbParent of - Nothing -> return Nothing - Just parent -> do - --trace ("Pane path " ++ show panePath) return () - newpane <- case dir of - Horizontal -> do h <- vPanedNew - return (castToPaned h) - Vertical -> do v <- hPanedNew - return (castToPaned v) - let (name,altname,paneDir) = case dir of - Horizontal -> ("top","bottom",TopP) - Vertical -> ("left","right",LeftP) - rName <- widgetGetName activeNotebook - widgetSetName newpane rName - nb <- newNotebook - widgetSetName nb altname - panedPack2 newpane nb True True - containerRemove (castToContainer parent) activeNotebook - widgetSetName activeNotebook name - panedPack1 newpane activeNotebook True True - if not (null panePath) - then - if (last panePath == TopP || last panePath == LeftP) - then panedPack1 (castToPaned parent) newpane True True - else panedPack2 (castToPaned parent) newpane True True - else do - boxPackStart (castToBox parent) newpane PackGrow 0 - boxReorderChild (castToVBox parent) newpane 2 - widgetShowAll newpane - widgetGrabFocus activeNotebook - return (Just (paneDir,dir)) - case mbPD of - Just (paneDir,dir) -> do - let toPane = panePath ++ [paneDir] - adjustPane panePath toPane - adjustLayoutForSplit dir panePath - Nothing -> return () - --- --- | Two notebooks can be collapsed to one --- -viewCollapse :: IDEAction -viewCollapse = do - mbPanePath <- getActivePanePath - case mbPanePath of - Nothing -> return () - Just panePath -> do - viewCollapse' panePath - -viewCollapse' :: PanePath -> IDEAction -viewCollapse' panePath = do - layout1 <- readIDE layout - let newPanePath = reverse $tail $reverse panePath - let mbOtherSidePath = otherSide panePath - case mbOtherSidePath of - Nothing -> ideMessage Normal "Can't collapse top level" - Just otherSidePath -> - let sp1 = getSubpath panePath layout1 - sp2 = getSubpath otherSidePath layout1 - in do - case sp1 of - Nothing -> return () - Just sp -> viewCollapse' sp - case sp2 of - Nothing -> return () - Just sp -> viewCollapse' sp - paneMap <- readIDE paneMap - activeNotebook <- getNotebook panePath - let paneNamesToMove = map (\(w,(p,_)) -> w) - $filter (\(w,(p,_)) -> p == otherSidePath) - $Map.toList paneMap - panesToMove <- mapM paneFromName paneNamesToMove - mapM_ (move panePath) panesToMove - lift $ do - mbParent <- widgetGetParent activeNotebook - case mbParent of - Nothing -> throwIDE "collapse: no parent" - Just parent -> do - mbGrandparent <- widgetGetParent parent - case mbGrandparent of - Nothing -> throwIDE "collapse: no grandparent" - Just grandparent -> do - containerRemove (castToContainer grandparent) parent - containerRemove (castToContainer parent) activeNotebook - if length panePath > 1 - then do - let dir = last newPanePath - if (dir == TopP || dir == LeftP) - then panedPack1 (castToPaned grandparent) - activeNotebook True True - else panedPack2 (castToPaned grandparent) - activeNotebook True True - widgetSetName activeNotebook $paneDirectionToWidgetName dir - else do - boxPackStart (castToVBox grandparent) activeNotebook PackGrow 0 - boxReorderChild (castToVBox grandparent) activeNotebook 2 - widgetSetName activeNotebook "root" - adjustLayoutForCollapse newPanePath - adjustPane panePath newPanePath - --adjustPane otherSidePath newPanePath - --- --- | Moves the given Pane to the given path --- -move :: PanePath -> IDEPane -> IDEAction -move toPane idew = do - paneMap <- readIDE paneMap - let child = getTopWidget idew - (fromPane,cid) <- guiPropertiesFromName (paneName idew) - fromNB <- getNotebook fromPane - toNB <- getNotebook toPane - lift $ do - mbNum <- notebookPageNum fromNB child - case mbNum of - Nothing -> return () - Just pn -> do - mbText <- notebookGetTabLabelText fromNB child - case mbText of - Nothing -> return () - Just text -> do - notebookRemovePage fromNB pn - notebookInsertOrdered toNB child text - let paneMap1 = Map.delete (paneName idew) paneMap - let newPaneMap = Map.insert (paneName idew) (toPane,cid) paneMap1 - modifyIDE_ (\ide -> return (ide{paneMap = newPaneMap})) - --- --- | Moves the activePane in the given direction, if possible --- | If their are many possibilities choose the leftmost and topmost --- -viewMove :: PaneDirection -> IDEAction -viewMove direction = do - mbPane <- readIDE activePane - case mbPane of - Nothing -> do - ideMessage Normal "no active pane" - return () - Just (paneName,_) -> do - pane <- paneFromName paneName - mbPanePath <- getActivePanePath - case mbPanePath of - Nothing -> do - ideMessage Normal "no active pane path" - return () - Just panePath -> do - layout <- readIDE layout - case findMoveTarget panePath layout direction of - Nothing -> do - ideMessage Normal "no target found" - return () - Just moveTo -> move moveTo pane - --- --- | Find the target for a move --- -findMoveTarget :: PanePath -> PaneLayout -> PaneDirection -> Maybe PanePath -findMoveTarget panePath layout direction= - let reversedPath = reverse panePath - oppositeDir = otherDirection direction - cutPath = dropWhile (\d -> d /= oppositeDir) reversedPath - in if null cutPath - then Nothing - else let basePath = reverse (direction : tail cutPath) - layoutP = layoutFromPath basePath layout - in Just $basePath ++ findAppropriate layoutP oppositeDir - -findAppropriate :: PaneLayout -> PaneDirection -> PanePath -findAppropriate (TerminalP _ _) _ = [] -findAppropriate (HorizontalP t b _) LeftP = TopP : findAppropriate t LeftP -findAppropriate (HorizontalP t b _) RightP = TopP : findAppropriate t RightP -findAppropriate (HorizontalP t b _) BottomP = BottomP : findAppropriate b BottomP -findAppropriate (HorizontalP t b _) TopP = TopP : findAppropriate b TopP -findAppropriate (VerticalP l r _) LeftP = LeftP : findAppropriate l LeftP -findAppropriate (VerticalP l r _) RightP = RightP : findAppropriate r RightP -findAppropriate (VerticalP l r _) BottomP = LeftP : findAppropriate l BottomP -findAppropriate (VerticalP l r _) TopP = LeftP : findAppropriate l TopP - --- --- | Bring the pane to the front position in its notebook --- -bringPaneToFront :: Pane alpha => alpha -> IO () -bringPaneToFront pane = do - let tv = getTopWidget pane - mbParent <- widgetGetParent tv - case mbParent of - Just parent -> do - let nb = castToNotebook parent - n <- notebookGetNPages nb - r <- filterM (\i -> do - mbp <- notebookGetNthPage nb i - case mbp of - Nothing -> return False - Just p -> do - mbs <- notebookGetTabLabelText nb p - case mbs of - Nothing -> return False - Just s -> return (s == paneName pane)) - [0..(n-1)] - case r of - [i] -> notebookSetCurrentPage nb i - otherwise -> return () - Nothing -> return () - --- --- | Get a concrete panePath from a standard path. --- Standard path is for example left top. --- -getStandardPanePath :: StandardPath -> PaneLayout -> PanePath -getStandardPanePath sp pl = reverse $ getStandard' sp pl [] - where - getStandard' _ (TerminalP _ _) p = p - getStandard' LeftTop (VerticalP l r _) p = getStandard' LeftTop l (LeftP:p) - getStandard' LeftBottom (VerticalP l r _) p = getStandard' LeftBottom l (LeftP:p) - getStandard' RightTop (VerticalP l r _) p = getStandard' RightTop r (RightP:p) - getStandard' RightBottom (VerticalP l r _) p = getStandard' RightBottom r (RightP:p) - getStandard' LeftTop (HorizontalP t b _) p = getStandard' LeftTop t (TopP:p) - getStandard' LeftBottom (HorizontalP t b _) p = getStandard' LeftBottom b (BottomP:p) - getStandard' RightTop (HorizontalP t b _) p = getStandard' RightTop t (TopP:p) - getStandard' RightBottom (HorizontalP t b _) p = getStandard' RightBottom b (BottomP:p) - --- --- | Construct a new notebook --- -newNotebook :: IO Notebook -newNotebook = do - nb <- notebookNew - notebookSetTabPos nb PosTop - notebookSetShowTabs nb True - notebookSetScrollable nb True - notebookSetPopup nb True - return nb - - --- --- | Get another pane path which points to the other side at the same level --- -otherSide :: PanePath -> Maybe PanePath -otherSide [] = Nothing -otherSide p = let rp = reverse p - ae = otherDirection $head rp - in Just (reverse $ae : tail rp) - --- --- | Get the opposite direction of a pane direction --- -otherDirection :: PaneDirection -> PaneDirection -otherDirection LeftP = RightP -otherDirection RightP = LeftP -otherDirection TopP = BottomP -otherDirection BottomP = TopP - --- --- | Get the layout at the given pane path --- -layoutFromPath :: PanePath -> PaneLayout -> PaneLayout -layoutFromPath [] l = l -layoutFromPath (TopP:r) (HorizontalP t _ _) = layoutFromPath r t -layoutFromPath (BottomP:r) (HorizontalP _ b _) = layoutFromPath r b -layoutFromPath (LeftP:r) (VerticalP l _ _) = layoutFromPath r l -layoutFromPath (RightP:r) (VerticalP _ ri _) = layoutFromPath r ri -layoutFromPath pp l = error - $"inconsistent layout " ++ show pp ++ " " ++ show l - - -getNotebookOrPaned :: PanePath -> (Widget -> beta) -> IDEM beta -getNotebookOrPaned p cf = (widgetGet $["topBox","root"] ++ map paneDirectionToWidgetName p) cf - --- --- | Get the notebook widget for the given pane path --- -getNotebook :: PanePath -> IDEM Notebook -getNotebook p = getNotebookOrPaned p castToNotebook - --- --- | Get the (gtk) Paned widget for a given path --- -getPaned :: PanePath -> IDEM Paned -getPaned p = getNotebookOrPaned p castToPaned - --- --- | Get the path to the active pane --- -getActivePanePath :: IDEM (Maybe PanePath) -getActivePanePath = do - mbPane <- readIDE activePane - case mbPane of - Nothing -> return Nothing - Just (paneName,_) -> do - (pp,_) <- guiPropertiesFromName paneName - return (Just (pp)) - -getActivePanePathOrStandard :: StandardPath -> IDEM (PanePath) -getActivePanePathOrStandard sp = do - mbApp <- getActivePanePath - case mbApp of - Just app -> return app - Nothing -> do - layout <- readIDE layout - return (getStandardPanePath sp layout) - - --- --- | Get the active notebook --- -getActiveNotebook :: IDEM (Maybe Notebook) -getActiveNotebook = do - mbPanePath <- getActivePanePath - case mbPanePath of - Just panePath -> do - nb <- getNotebook panePath - return (Just nb) - Nothing -> return Nothing - - --- --- | Translates a pane direction to the widget name --- -paneDirectionToWidgetName :: PaneDirection -> String -paneDirectionToWidgetName TopP = "top" -paneDirectionToWidgetName BottomP = "bottom" -paneDirectionToWidgetName LeftP = "left" -paneDirectionToWidgetName RightP = "right" - --- --- | Changes a pane path in the pane map --- -adjustPane :: PanePath -> PanePath -> IDEAction -adjustPane fromPane toPane = do - paneMap <- readIDE paneMap - let newMap = Map.map (\(pp,other) -> do - if pp == fromPane - then (toPane,other) - else (pp,other)) paneMap - modifyIDE_ $ \ide -> return (ide{paneMap = newMap}) - --- --- | Changes the layout for a split --- -adjustLayoutForSplit :: Direction -> PanePath -> IDEAction -adjustLayoutForSplit dir path = do - layout <- readIDE layout - let newTerm = case dir of - Horizontal -> HorizontalP (TerminalP Nothing 0) (TerminalP Nothing 0) 0 - Vertical -> VerticalP (TerminalP Nothing 0) (TerminalP Nothing 0) 0 - let newLayout = adjust path layout newTerm - modifyIDE_ $ \ide -> return (ide{layout = newLayout}) - --- --- | Changes the layout for a collapse (HorizontalP TerminalP (VerticalP (HorizontalP TerminalP TerminalP) TerminalP)) - --- -adjustLayoutForCollapse :: PanePath -> IDEAction -adjustLayoutForCollapse path = do - layout <- readIDE layout - let newLayout = adjust path layout (TerminalP Nothing 0) - modifyIDE_ $ \ide -> return (ide{layout = newLayout}) - -getSubpath :: PanePath -> PaneLayout -> Maybe PanePath -getSubpath path layout = - case layoutFromPath path layout of - TerminalP _ _ -> Nothing - HorizontalP _ _ _ -> Just (path ++ [TopP]) - VerticalP _ _ _ -> Just (path ++ [LeftP]) - --- --- | Changes the layout by replacing element at pane path with replace --- -adjust :: PanePath -> PaneLayout -> PaneLayout -> PaneLayout -adjust pp layout replace = adjust' pp layout - where - adjust' [] _ = replace - adjust' (TopP:r) (HorizontalP tp bp _) = HorizontalP (adjust' r tp) bp 0 - adjust' (BottomP:r) (HorizontalP tp bp _) = HorizontalP tp (adjust' r bp) 0 - adjust' (LeftP:r) (VerticalP lp rp _) = VerticalP (adjust' r lp) rp 0 - adjust' (RightP:r) (VerticalP lp rp _) = VerticalP lp (adjust' r rp) 0 - adjust' p l = throwIDE $"inconsistent layout " ++ show p ++ " " ++ show l - --- --- | Get the widget from a list of strings --- -widgetFromPath :: Widget -> [String] -> IO (Widget) -widgetFromPath w [] = return w -widgetFromPath w (h:t) = do - children <- containerGetChildren (castToContainer w) - names <- mapM widgetGetName children - let mbiInd = findIndex (== h) names - case mbiInd of - Nothing -> throwIDE $"Cant't find widget path " ++ show (h:t) - Just ind -> widgetFromPath (children !! ind) t - - -widgetGet :: [String] -> (Widget -> b) -> IDEM (b) -widgetGet strL cf = do - w <- readIDE window - r <- lift $widgetFromPath (castToWidget w) strL - return (cf r) - -widgetGetRel :: Widget -> [String] -> (Widget -> b) -> IO (b) -widgetGetRel w sl cf = do - r <- widgetFromPath w sl - return (cf r) - -getUIAction :: String -> (Action -> a) -> IDEM(a) -getUIAction str f = do - uiManager <- readIDE uiManager - lift $ do - findAction <- uiManagerGetAction uiManager str - case findAction of - Just act -> return (f act) - Nothing -> throwIDE $"getUIAction can't find action " ++ str - ---get widget elements - -getCandyState :: IDEM (Bool) -getCandyState = do - ui <- getUIAction "ui/menubar/_Edit/Source Candy" castToToggleAction - lift $toggleActionGetActive ui - -setCandyState :: Bool -> IDEAction -setCandyState b = do - ui <- getUIAction "ui/menubar/_Edit/Source Candy" castToToggleAction - lift $toggleActionSetActive ui b --- - -getSBSpecialKeys :: IDEM (Statusbar) -getSBSpecialKeys = widgetGet ["topBox","statusBox","statusBarSpecialKeys"] castToStatusbar - -getSBActivePane :: IDEM (Statusbar) -getSBActivePane = widgetGet ["topBox","statusBox","statusBarActivePane"] castToStatusbar - -getSBActivePackage :: IDEM (Statusbar) -getSBActivePackage = widgetGet ["topBox","statusBox","statusBarActiveProject"] castToStatusbar - -getSBErrors :: IDEM (Statusbar) -getSBErrors = widgetGet ["topBox","statusBox","statusBarErrors"] castToStatusbar - -getStatusbarIO :: IDEM (Statusbar) -getStatusbarIO = widgetGet ["topBox","statusBox","statusBarInsertOverwrite"] castToStatusbar - -getStatusbarLC :: IDEM (Statusbar) -getStatusbarLC = widgetGet ["topBox","statusBox","statusBarLineColumn"] castToStatusbar - - diff --git a/src/IDE/GUIHistory.hs b/src/IDE/GUIHistory.hs new file mode 100644 --- /dev/null +++ b/src/IDE/GUIHistory.hs @@ -0,0 +1,97 @@ +{-# OPTIONS_GHC #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.GUIHistory +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- +-- | Recording the history for going back and forth +-- +--------------------------------------------------------------------------------- + + +module IDE.GUIHistory ( + recordHistory +, historyBack +, historyForward +, withoutRecordingDo +) where + +import IDE.Core.State +import IDE.Pane.Modules +import IDE.Pane.Info +import Control.Event +import Control.Monad.Reader + +recordHistory :: GUIHistory -> IDEAction +recordHistory entry = do + (b,l,n) <- readIDE guiHistory + if b || (n >= 0 && fst entry == fst (l !! n)) + then return () + else do + modifyIDE_ (\ide -> return ide{guiHistory = (b,entry:(drop n l),0)}) + st <- ask + triggerEvent st (Sensitivity + [(SensitivityForwardHist,False),(SensitivityBackwardHist,0 < length (drop n l) - 1)]) + return () + -- liftIO $ putStrLn $ "record n : " ++ show 0 -- ++ " hist: " ++ show (entry:(drop n l)) + +historyBack :: IDEAction +historyBack = do + (b,list,index) <- readIDE guiHistory + case (list,index) of + (_,-1) -> return () + (l,n) | n + 1 >= length l -> return () + | otherwise -> do + withoutRecordingDo (activateHistory (snd (l !! n))) + modifyIDE_ (\ide -> return ide{guiHistory = (b,l, n + 1)}) + st <- ask + triggerEvent st (Sensitivity + [(SensitivityForwardHist,(n + 1) > 0),(SensitivityBackwardHist,(n + 1) < (length l) - 1)]) + return () + -- liftIO $ putStrLn $ "back n : " ++ show (n + 1) -- ++ " hist: " ++ show l + + +historyForward :: IDEAction +historyForward = do + (b,list,index) <- readIDE guiHistory + case (list,index) of + (l,n) | n < 1 -> return () + | otherwise -> do + withoutRecordingDo (activateHistory (fst (l !! n))) + modifyIDE_ (\ide -> return ide{guiHistory = (b,l, n - 1)}) + st <- ask + triggerEvent st (Sensitivity + [(SensitivityForwardHist,(n - 1) > 0),(SensitivityBackwardHist,(n - 1) < (length l) - 1)]) + return () + -- liftIO $ putStrLn $ "forward n : " ++ show (n - 1) -- ++ " hist: " ++ show l + +activateHistory :: GUIHistory' -> IDEAction +activateHistory ms@(ModuleSelected s1 s2) = do + -- liftIO $ putStrLn $ "activate with module selected " ++ show s1 ++ " " ++ show s2 + replaySelHistory s1 s2 +activateHistory ms@(ScopeSelected bl sc) = do + -- liftIO $ putStrLn $ "activate with scope selected " ++ show ms + replayScopeHistory bl sc +activateHistory ms@(InfoElementSelected descr) = do + -- liftIO $ putStrLn $ "activate with " ++ show ms + replayInfoHistory descr +activateHistory ms@(PaneSelected mbPaneName) = do + -- liftIO $ putStrLn $ "activate with " ++ show ms + case mbPaneName of + Nothing -> withoutRecordingDo deactivatePane + Just paneName -> do + mbPane <- mbPaneFromName paneName + case mbPane of + Nothing -> return () + Just (PaneC p) -> do + makeActive p + return () + + + diff --git a/src/IDE/InfoPane.hs b/src/IDE/InfoPane.hs deleted file mode 100644 --- a/src/IDE/InfoPane.hs +++ /dev/null @@ -1,318 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- --- Module : IDE.InfoPane --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | The GUI stuff for infos --- -------------------------------------------------------------------------------- - -module IDE.InfoPane ( - setInfos -, setSymbol -) where - -import Graphics.UI.Gtk hiding (afterToggleOverwrite) -import Control.Monad.Reader -import System.IO -import Control.Monad -import Control.Monad.Trans -import System.IO -import Data.List -import Data.Maybe -import qualified Data.ByteString.Char8 as BS -import Data.IORef(newIORef,readIORef,writeIORef) -import qualified Data.Map as Map - -import IDE.Core.State -import IDE.Framework.ViewFrame -import IDE.Framework.MakeEditor -import IDE.Framework.SimpleEditors -import IDE.Framework.Parameters -import IDE.SourceEditor -import IDE.CallersPane -import IDE.Framework.EditorBasics - -instance IDEObject IDEInfo - -instance Pane IDEInfo - where - primPaneName _ = "Info" - getAddedIndex _ = 0 - getTopWidget = castToWidget . sw - paneId b = "*Info" - makeActive pane = activatePane pane (BufConnections[][][]) - close pane = do - (panePath,_) <- guiPropertiesFromName (paneName pane) - nb <- getNotebook panePath - mbI <- lift $notebookPageNum nb (getTopWidget pane) - case mbI of - Nothing -> lift $ do - sysMessage Normal "notebook page not found: unexpected" - return () - Just i -> do - deactivatePaneIfActive pane - lift $notebookRemovePage nb i - removePaneAdmin pane - -instance RecoverablePane IDEInfo InfoState where - saveState p = do - currentIDsU <- lift $ readIORef (currentIDs p) - currentIndU <- lift $ readIORef (currentInd p) - return (Just (StateC (InfoState currentIDsU currentIndU))) - recoverState pp (InfoState currentIDsU currentIndu) = do - nb <- getNotebook pp - initInfo pp nb currentIDsU currentIndu - -idDescrDescr :: IDERef -> [FieldDescription IdentifierDescr] -idDescrDescr ideR = [ - mkField - (paraName <<<- ParaName "Symbol" - $ paraHorizontal <<<- ParaHorizontal StartHorizontal - $ emptyParams) - identifierID - (\ b a -> a{identifierID = b}) - stringEditor - , mkField - (paraName <<<- ParaName "Sort" - $ emptyParams) - idType - (\b a -> a) - (staticSelectionEditor allIdTypes) - , mkField - (paraName <<<- ParaName "Exported by" - $ paraHorizontal <<<- ParaHorizontal StopHorizontal - $ emptyParams) - (\l -> showPackModule (moduleIdID l)) - (\ b a -> a{moduleIdID = parsePackModule b}) - stringEditor - , mkField - (paraName <<<- ParaName "Type" $ emptyParams) - (BS.unpack . typeInfo) - (\b a -> a) - (typeEditor ideR) - , mkField - (paraName <<<- ParaName "Comment" $ emptyParams) - (\l -> case mbComment l of - Nothing -> "" - Just s -> BS.unpack s) - (\ b a -> case b of - "" -> a{mbComment = Nothing} - s -> a{mbComment = Just (BS.pack s)}) - multilineStringEditor] - -{-- , mkField (emptyParams - {paraName = Just "Documentation"}) - typeInfo - (\b a -> a{typeInfo = b}) - multilineStringEditor--} - -allIdTypes = [Function, Newtype, Type, AbstractData, OpenData, Foreign - , Data, Class, Instance, Constructor, Field, Method, OrphanedInstance] - -typeEditor :: IDERef -> Editor String -typeEditor ideR para = do - ed@(wid,inj,ext,notif) <- multilineStringEditor para - notif ButtonRelease $Left (\e -> showInfoHandler wid ideR) - return ed - -showInfoHandler :: Widget -> IDERef -> IO Bool -showInfoHandler wid ideR = do - mbFrame <- binGetChild (castToAlignment wid) - mbInner <- binGetChild (castToFrame (forceJust mbFrame "InfoPane>>typeEditor: Can't find child")) - mbScrolled <- binGetChild (castToAlignment (forceJust mbInner "InfoPane>>typeEditor: Can't find child2")) - mbTV <- binGetChild (castToScrolledWindow (forceJust mbScrolled "InfoPane>>typeEditor: Can't find child3")) - buf <- textViewGetBuffer (castToTextView (forceJust mbTV "InfoPane>>typeEditor: Can't find child4")) - (l,r) <- textBufferGetSelectionBounds buf - symbol <- textBufferGetText buf l r True - runReaderT (triggerEvent ideR (SelectInfo symbol)) ideR - return False - -initInfo :: PanePath -> Notebook -> [IdentifierDescr] -> Int -> IDEAction -initInfo panePath nb idDescrs index = do - when (length idDescrs > index) $ do - ideR <- ask - panes <- readIDE panes - paneMap <- readIDE paneMap - prefs <- readIDE prefs - (pane,cids) <- lift $ do - nbbox <- hBoxNew False 0 - ibox <- vBoxNew False 0 - bb <- vButtonBoxNew - buttonBoxSetLayout bb ButtonboxStart - definitionB <- buttonNewWithLabel "Source" - moduB <- buttonNewWithLabel "Selection" - usesB <- buttonNewWithLabel "Uses" - docuB <- buttonNewWithLabel "Docu" - widgetSetSensitivity docuB False - nextB <- buttonNewWithLabel "Next" - prevB <- buttonNewWithLabel "Prev" - when (length idDescrs < 2) $ widgetSetSensitivity nextB False - widgetSetSensitivity prevB False - label <- labelNew (Just ("1" ++ "/" ++ show (length idDescrs))) - boxPackStart bb definitionB PackNatural 0 - boxPackStart bb moduB PackNatural 0 - boxPackStart bb usesB PackNatural 0 - boxPackStart bb docuB PackNatural 0 - boxPackStart bb label PackNatural 0 - boxPackStart bb nextB PackNatural 0 - boxPackStart bb prevB PackNatural 0 - - resList <- mapM (\ fd -> (fieldEditor fd) (head idDescrs)) (idDescrDescr ideR) - let (widgets, setInjs, getExts, notifiers) = unzip4 resList - foldM_ (\ box (w,mbh) -> - case mbh of - Keep -> do boxPackStart box w PackGrow 0 - return box - StartHorizontal -> do newBox <- hBoxNew True 0 - boxPackStart box newBox PackNatural 0 - boxPackStart newBox w PackGrow 0 - return (castToBox newBox) - StopHorizontal -> do boxPackStart box w PackGrow 0 - par <- widgetGetParent box - case par of - Nothing -> throwIDE "initInfo - no parent" - Just p -> return (castToBox p)) - (castToBox ibox) - (zip widgets (map (getParameter paraHorizontal . parameters) - (idDescrDescr ideR))) - boxPackStart nbbox ibox PackGrow 0 - boxPackEnd nbbox bb PackNatural 0 - --openType - sw <- scrolledWindowNew Nothing Nothing - scrolledWindowAddWithViewport sw nbbox - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - currentIDs' <- newIORef idDescrs - currentInd <- newIORef 0 - let info = IDEInfo sw currentIDs' currentInd setInjs getExts nextB prevB label - - --mapM_ (\w -> widgetSetExtensionEvents w [ExtensionEventsAll]) widgets - cids <- mapM - (\w -> w `onFocus` --onFocusIn doesn't work here - why? - (\_ -> do runReaderT (makeActive info) ideR - return False)) - widgets - definitionB `onClicked` (runReaderT gotoSource ideR) - moduB `onClicked` (runReaderT gotoModule' ideR) - usesB `onClicked` (runReaderT calledBy' ideR) - nextB `onClicked` (next info) - prevB `onClicked` (prev info) - notebookInsertOrdered nb sw (paneName info) - widgetShowAll sw - return (info,cids) - addPaneAdmin pane (BufConnections [] [] []) panePath - lift $widgetGrabFocus (sw pane) - lift $bringPaneToFront pane - -next :: IDEInfo -> IO () -next (IDEInfo _ currentIDs' currentInd' injectors' _ nextB prevB label) = do - currentIdsU <- readIORef currentIDs' - currentIndU <- readIORef currentInd' - when (length currentIdsU > currentIndU + 1) $ do - writeIORef currentInd' (currentIndU + 1) - mapM_ (\ a -> a (currentIdsU !! (currentIndU + 1))) injectors' - when (length currentIdsU == currentIndU + 1) $ widgetSetSensitivity nextB False - widgetSetSensitivity prevB True - labelSetText label (show (currentIndU + 2) ++ "/" ++ show (length currentIdsU)) - - -prev :: IDEInfo -> IO () -prev (IDEInfo _ currentIDs' currentInd' injectors' _ nextB prevB label) = do - currentIdsU <- readIORef currentIDs' - currentIndU <- readIORef currentInd' - when (currentIndU >= 1) $ do - writeIORef currentInd' (currentIndU - 1) - mapM_ (\ a -> a (currentIdsU !! (currentIndU - 1))) injectors' - when (currentIndU - 1 == 0) $ widgetSetSensitivity prevB False - widgetSetSensitivity nextB True - labelSetText label (show currentIndU ++ "/" ++ show (length currentIdsU)) - -gotoSource :: IDEAction -gotoSource = do - mbInfo <- getInfoCont - case mbInfo of - Nothing -> do ideMessage Normal "gotoSource:noDefition" - return () - Just info -> do goToDefinition info - return () - -gotoModule' :: IDEAction -gotoModule' = do - mbInfo <- getInfoCont - ideR <- ask - case mbInfo of - Nothing -> return () - Just info -> do triggerEvent ideR (SelectIdent info) - return () - -calledBy' :: IDEAction -calledBy' = do - mbInfo <- getInfoCont - case mbInfo of - Nothing -> return () - Just info -> do calledBy info - return () - -setSymbol :: String -> IDEAction -setSymbol symbol = do - currentInfo' <- readIDE currentInfo - case currentInfo' of - Nothing -> return () - Just ((_,symbolTable1),(_,symbolTable2)) -> - case getIdentifierDescr symbol symbolTable1 symbolTable2 of - [] -> return () - a -> setInfos a - - -setInfos :: [IdentifierDescr] -> IDEM () -setInfos identifierDescrs = do - mbPane <- getPane InfoCasting - case mbPane of - Nothing -> do - prefs <- readIDE prefs - layout <- readIDE layout - let pp = getStandardPanePath (infoPanePath prefs) layout - nb <- getNotebook pp - initInfo pp nb identifierDescrs 0 - Just info -> lift $ do - writeIORef (currentInd info) 0 - writeIORef (currentIDs info) identifierDescrs - mapM_ (\ a -> a (head identifierDescrs)) (injectors info) - labelSetText (numLabel info) ("1/" ++ show (length identifierDescrs)) - widgetSetSensitivity (prevB info) False - widgetSetSensitivity (nextB info) - (if length identifierDescrs > 1 then True else False) - bringPaneToFront info - - -getInfoCont :: IDEM (Maybe (IdentifierDescr)) -getInfoCont = do - mbPane <- getPane InfoCasting - case mbPane of - Nothing -> return Nothing - Just p -> lift $ do - currentIndU <- readIORef (currentInd p) - currentIDsU <- readIORef (currentIDs p) - if length currentIDsU > currentIndU - then return (Just (currentIDsU !! currentIndU)) - else return Nothing - --- --- | Lookup of an identifier description --- -getIdentifierDescr :: String -> SymbolTable -> SymbolTable -> [IdentifierDescr] -getIdentifierDescr str st1 st2 = - case str `Map.lookup` st1 of - Nothing -> case str `Map.lookup` st2 of - Nothing -> [] - Just list -> list - Just list -> case str `Map.lookup` st2 of - Nothing -> list - Just list2 -> list ++ list2 - diff --git a/src/IDE/Keymap.hs b/src/IDE/Keymap.hs --- a/src/IDE/Keymap.hs +++ b/src/IDE/Keymap.hs @@ -8,12 +8,13 @@ ) where import Graphics.UI.Gtk +import Graphics.UI.Gtk.Gdk.Events(Modifier(..)) 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.List (foldl',sort) import Data.Char(toLower) import Control.Monad.Reader @@ -50,7 +51,7 @@ where setAccel act = case Map.lookup (name act) keymap of Nothing -> act Just [] -> act - Just keyList -> foldl setAccelerator act keyList + 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} @@ -170,9 +171,9 @@ return Alt <|> do try $symbol2 "" - return Apple + return Super <|> do try $symbol2 "" - return Compose + return Hyper "modparser" diff --git a/src/IDE/Leksah.hs b/src/IDE/Leksah.hs --- a/src/IDE/Leksah.hs +++ b/src/IDE/Leksah.hs @@ -1,16 +1,17 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} + +{-# OPTIONS_GHC -XScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Leksah -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL -- --- Maintainer : Juergen Nicklisch-Franken +-- Maintainer : Juergen Nicklisch-Franken -- Stability : experimental -- Portability : portable -- -- --- Main function of Genuine Haskell Face, an Haskell IDE written in Haskell +-- Main function of Leksah, an Haskell IDE written in Haskell -- --------------------------------------------------------------------------------- @@ -19,6 +20,8 @@ ) where import Graphics.UI.Gtk +import Graphics.UI.Gtk.Gdk.Events +import qualified Graphics.UI.Gtk.Gdk.Events as GdkEvents import Control.Monad.Reader import Control.Concurrent import Data.IORef @@ -28,39 +31,43 @@ import System.Console.GetOpt import System.Environment import GHC +import HscTypes hiding (liftIO) import Config import Data.Version import Prelude hiding(catch) import System.FilePath import System.Directory - +import Debug.Trace import Paths_leksah import IDE.SaveSession import IDE.Core.State +import Control.Event import IDE.SourceCandy -import IDE.Utils.File -import IDE.Framework.ViewFrame -import IDE.Framework.MakeEditor -import IDE.Framework.Parameters +import IDE.FileUtils +import Graphics.UI.Editor.MakeEditor +import Graphics.UI.Editor.Parameters import IDE.Menu -import IDE.Preferences +import IDE.Pane.Preferences import IDE.Keymap -import IDE.SourceEditor +import IDE.Pane.SourceBuffer import IDE.SpecialEditors -import IDE.Metainfo.Info +import IDE.Metainfo.Provider import IDE.Metainfo.SourceCollector import IDE.Metainfo.InterfaceCollector -import IDE.Log(getLog,appendLog) -import IDE.InfoPane -import IDE.ModulesPane - +import IDE.Pane.Log +import IDE.Pane.Info +import IDE.Pane.Modules +import IDE.GUIHistory +import IDE.Pane.Search(setChoices,searchMetaGUI) +import IDE.Find -- --------------------------------------------------------------------- -- Command line options -- data Flag = UninstalledProject String | Collect | Rebuild | Sources | VersionF | DebugF + | SessionN String | NoGUI deriving (Show,Eq) options :: [OptDescr Flag] @@ -75,8 +82,13 @@ , Option ['v'] ["Version"] (NoArg VersionF) "Show the version number of ide" , Option ['d'] ["Debug"] (NoArg DebugF) - "Write ascii pack files"] + "Write ascii pack files" + , Option ['l'] ["LoadSession"] (ReqArg SessionN "NAME") + "Load session" + , Option ['n'] ["NoGUI"] (NoArg NoGUI) + "Don't start the leksah GUI"] + ideOpts :: [String] -> IO ([Flag], [String]) ideOpts argv = case getOpt Permute options argv of @@ -89,50 +101,47 @@ -- | Main function -- -runMain = handleTopExceptions $do +runMain = handleTopExceptions $ do args <- getArgs - (o,_) <- ideOpts args - let uninstalled = filter (\x -> case x of + (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 + let sessions = filter (\x -> case x of + SessionN _ -> True + _ -> False) o + let sessionFilename = if not (null sessions) + then (head $ map (\ (SessionN x) -> x) sessions) ++ ".session" + else "Current.session" + when (elem VersionF o) + (sysMessage Normal $ "Leksah an IDE for Haskell, version " ++ showVersion version) + when (elem Sources o) (do + buildSourceForPackageDB + sysMessage Normal "rebuild SourceForPackageDB") + when (elem Rebuild o || elem Collect o || not (null uninstalled)) $ do + libDir <- getSysLibDir + runGhc (Just libDir) $ do + getSessionDynFlags >>= setSessionDynFlags + 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 version) + $ map (\ (UninstalledProject x) -> x) uninstalled + else do + sources <- liftIO $ getSourcesMap + collectInstalled' writeAscii version (elem Rebuild o) sources + when (not (elem NoGUI o) && not (elem VersionF o)) (startGUI sessionFilename) -- --------------------------------------------------------------------- -- | Start the GUI -startGUI :: IO () -startGUI = do --- sysMessage Normal "Leksah says welcome" - st <- initGUI +startGUI :: String -> IO () +startGUI sessionFilename = do + trace "start gui called" $ return () + st <- unsafeInitGUIForThreadedRTS -- initGUI when rtsSupportsBoundThreads (sysMessage Normal "Linked with -threaded") timeoutAddFull (yield >> return True) priorityHigh 25 @@ -158,63 +167,93 @@ 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 + findBar <- liftIO $ toolbarNew + toolbarSetStyle findBar ToolbarIcons let ide = IDE { window = win , uiManager = uiManager , panes = Map.empty , activePane = Nothing + , lastActiveBufferPane = 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} + , handlers = Map.empty + , isShuttingDown = False + , guiHistory = (False,[],-1) + , findbar = findBar + , toolbar = Nothing + , findbarVisible = True + , toolbarVisible = True +} 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 + libDir <- getSysLibDir + runGhc (Just libDir) (do + getSessionDynFlags >>= setSessionDynFlags + reifyGhc (\session -> do + menuDescription' <- menuDescription + (acc,menus) <- reflectIDE (makeMenu uiManager accelActions menuDescription') ideR session + when (length menus /= 2) $ throwIDE ("Failed to build menu" ++ show (length menus)) + let toolbar = castToToolbar (menus !! 1) + reflectIDE (do + constructFindReplace findBar + modifyIDE_ (\ide -> return ide{toolbar = Just toolbar}) + initInfo :: IDEAction) ideR session + sep0 <- separatorToolItemNew + separatorToolItemSetDraw sep0 False + toolItemSetExpand sep0 True + toolbarInsert toolbar sep0 (-1) + closeButton <- toolButtonNewFromStock "gtk-close" + toolbarInsert toolbar closeButton (-1) + closeButton `onToolButtonClicked` do + reflectIDE hideToolbar ideR session + windowAddAccelGroup win acc + nb <- newNotebook + afterSwitchPage nb (\i -> reflectIDE (handleNotebookSwitch nb i) ideR session) + widgetSetName nb $"root" + statusBar <- buildStatusbar ideR + vb <- vBoxNew False 1 -- Top-level vbox + widgetSetName vb "topBox" + toolbarSetStyle (castToToolbar (menus !! 1)) ToolbarIcons + boxPackStart vb (menus !! 0) PackNatural 0 + boxPackStart vb (menus !! 1) PackNatural 0 + boxPackStart vb nb PackGrow 0 + boxPackStart vb findBar PackNatural 0 + boxPackEnd vb statusBar PackNatural 0 + win `onDelete` (\ _ -> do reflectIDE quit ideR session; return True) + win `onKeyPress` (\ e -> reflectIDE (handleSpecialKeystrokes e) ideR session) + containerAdd win vb + reflectIDE (setCandyState (isJust (sourceCandy prefs))) ideR session + let (x,y) = defaultSize prefs + windowSetDefaultSize win x y + sessionPath <- getConfigFilePathForLoad sessionFilename + (tbv,fbv) <- reflectIDE (do + registerEvents menus + recoverSession sessionPath + ) ideR session + widgetShowAll win + reflectIDE (do + if tbv + then showToolbar + else hideToolbar + if fbv + then showFindbar + else hideFindbar) ideR session + mainGUI)) + -- -- | Callback function for onKeyPress of the main window, so preprocess any key -- -handleSpecialKeystrokes :: Event -> IDEM Bool +handleSpecialKeystrokes :: GdkEvents.Event -> IDEM Bool handleSpecialKeystrokes (Key _ _ _ mods _ _ _ keyVal name mbChar) = do bs <- getCandyState when bs $ editKeystrokeCandy mbChar @@ -225,27 +264,27 @@ Nothing -> do case Map.lookup (keyVal,sort mods) sks of Nothing -> do - lift $statusbarPop sb 1 - lift $statusbarPush sb 1 "" + liftIO $statusbarPop sb 1 + liftIO $statusbarPush sb 1 "" return False Just map -> do sb <- getSBSpecialKeys let sym = printMods mods ++ name - lift $statusbarPop sb 1 - lift $statusbarPush sb 1 sym + liftIO $statusbarPop sb 1 + liftIO $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 ++ "?" + liftIO $statusbarPop sb 1 + liftIO $statusbarPush sb 1 $sym ++ printMods mods ++ name ++ "?" return () Just (AD actname _ _ _ ideAction _ _) -> do sb <- getSBSpecialKeys - lift $statusbarPop sb 1 - lift $statusbarPush sb 1 + liftIO $statusbarPop sb 1 + liftIO $statusbarPush sb 1 $sym ++ " " ++ printMods mods ++ name ++ "=" ++ actname ideAction modifyIDE_ (\ide -> return (ide{specialKey = Nothing})) @@ -256,27 +295,33 @@ printMods (m:r) = show m ++ printMods r handleSpecialKeystrokes _ = return True +-- +-- | Register handlers for IDE events +-- 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) + registerEvent stRef "LogMessage" (Left logHandler) + registerEvent stRef "SelectInfo" (Left siHandler) + registerEvent stRef "SelectIdent" (Left sidHandler) + registerEvent stRef "CurrentInfo" (Left ciuHandler) + registerEvent stRef "ActivePack" (Left apHandler) + registerEvent stRef "RecordHistory" (Left rhHandler) + registerEvent stRef "Sensitivity" (Left sHandler) + registerEvent stRef "DescrChoice" (Left dcHandler) + registerEvent stRef "SearchMeta" (Left smHandler) + registerEvent stRef "LoadSession" (Left lsHandler) + registerEvent stRef "SaveSession" (Left ssHandler) + return () where logHandler e@(LogMessage s t) = do (log :: IDELog) <- getLog - lift $ appendLog log s t + liftIO $ 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 @@ -297,11 +342,30 @@ return ActivePack apHandler _ = throwIDE "Leksah>>registerEvents: Impossible event" + rhHandler rh@(RecordHistory h) = do + recordHistory h + return rh + rhHandler _ = throwIDE "Leksah>>registerEvents: Impossible event" + sHandler s@(Sensitivity h) = do + setSensitivity h + return s + sHandler _ = throwIDE "Leksah>>registerEvents: Impossible event" --- --- | Called when leksah ist first called --- + dcHandler e@(DescrChoice descrs) = do + setChoices descrs + return e + dcHandler _ = throwIDE "Leksah>>registerEvents: Impossible event" + + smHandler e@(SearchMeta string) = searchMetaGUI string >> return e + smHandler _ = throwIDE "Leksah>>registerEvents: Impossible event" + + lsHandler e@(LoadSession fp) = loadSession fp >> return e + lsHandler _ = throwIDE "Leksah>>registerEvents: Impossible event" + + ssHandler e@(SaveSession fp) = saveSessionAs fp >> return e + ssHandler _ = throwIDE "Leksah>>registerEvents: Impossible event" + fDescription :: FieldDescription Prefs fDescription = mkField @@ -312,6 +376,9 @@ (\b a -> a{sourceDirectories = b}) (filesEditor Nothing FileChooserActionSelectFolder "Select folders") +-- +-- | Called when leksah ist first called (the .leksah directory does not exist) +-- firstStart :: IO () firstStart = do prefsPath <- getConfigFilePathForLoad "Default.prefs" @@ -328,7 +395,7 @@ "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 + <- buildEditor fDescription prefs ok `onClicked` (do mbNewPrefs <- extract prefs [getExt] case mbNewPrefs of @@ -356,16 +423,10 @@ 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 +firstBuild = let version = cProjectVersion in do buildSourceForPackageDB sources <- getSourcesMap - collectInstalled' False session version True sources + libDir <- getSysLibDir + runGhc (Just libDir) $ collectInstalled' False version True sources + + diff --git a/src/IDE/Log.hs b/src/IDE/Log.hs deleted file mode 100644 --- a/src/IDE/Log.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} --- --- Module : IDE.Log --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | Log pane --- -------------------------------------------------------------------------------- - - -module IDE.Log ( - LogView(..) -, LogAction(..) -, IDELog(..) -, LogState -, LogTag(..) -) where - -import Graphics.UI.Gtk hiding (afterToggleOverwrite) -import Graphics.UI.Gtk.Multiline.TextView -import Control.Monad.Reader -import Data.Maybe - -import IDE.Core.State -import IDE.SourceEditor -import IDE.Framework.ViewFrame - - -------------------------------------------------------------------------------- --- --- * Interface --- - --- --- | The Log Viev --- - -class LogAction alpha where - clearLog :: alpha - -instance LogAction IDEAction where - clearLog = clearLog' - -class Pane alpha => LogView alpha where - getLog :: IDEM alpha - appendLog :: alpha -> String -> LogTag -> IO Int - markErrorInLog :: alpha -> (Int, Int) -> IO () - -instance IDEObject IDELog - -instance LogView IDELog - where - getLog = getLog' - appendLog = appendLog' - markErrorInLog = markErrorInLog' - -instance CastablePane IDELog where - casting _ = LogCasting - downCast _ (PaneC a) = case casting a of - LogCasting -> Just a - _ -> Nothing - - -instance Recoverable LogState where - toPaneState a = LogSt a - -instance Pane IDELog - where - primPaneName _ = "Log" - getAddedIndex _ = 0 - getTopWidget = castToWidget . scrolledWindowL - paneId b = "*Log" - makeActive log = do - activatePane log (BufConnections[][] []) - close pane = do - (panePath,_) <- guiPropertiesFromName (paneName pane) - nb <- getNotebook panePath - mbI <- lift $notebookPageNum nb (getTopWidget pane) - case mbI of - Nothing -> lift $ do - sysMessage Normal "notebook page not found: unexpected" - return () - Just i -> do - deactivatePaneIfActive pane - lift $notebookRemovePage nb i - removePaneAdmin pane - -instance RecoverablePane IDELog LogState where - saveState p = return (Just (StateC LogState)) - recoverState pp LogState = do - nb <- getNotebook pp - initLog pp nb - - -------------------------------------------------------------------------------- --- --- * Implementation --- - - -initLog :: PanePath -> Notebook -> IDEAction -initLog panePath nb = do - ideR <- ask - panes <- readIDE panes - paneMap <- readIDE paneMap - prefs <- readIDE prefs - (buf,cids) <- lift $ do - tv <- textViewNew - buf <- textViewGetBuffer tv - iter <- textBufferGetEndIter buf - textBufferCreateMark buf (Just "end") iter True - - tags <- textBufferGetTagTable buf - errtag <- textTagNew (Just "err") - set errtag[textTagForeground := "red"] - textTagTableAdd tags errtag - frametag <- textTagNew (Just "frame") - set frametag[textTagForeground := "green"] - textTagTableAdd tags frametag - activeErrtag <- textTagNew (Just "activeErr") - set activeErrtag[textTagBackground := "yellow"] - textTagTableAdd tags activeErrtag - - textViewSetEditable tv True - fd <- case logviewFont prefs of - Just str -> do - fontDescriptionFromString str - Nothing -> do - f <- fontDescriptionNew - fontDescriptionSetFamily f "Sans" - return f - widgetModifyFont tv (Just fd) - sw <- scrolledWindowNew Nothing Nothing - containerAdd sw tv - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - scrolledWindowSetShadowType sw ShadowIn - - let buf = IDELog tv sw - notebookInsertOrdered nb sw (paneName buf) - widgetShowAll (scrolledWindowL buf) - cid1 <- tv `afterFocusIn` - (\_ -> do runReaderT (makeActive buf) ideR; return True) - cid2 <- tv `onButtonPress` - (\ b -> do runReaderT (clicked b buf) ideR; return True) - return (buf,[cid1]) - addPaneAdmin buf (BufConnections [] [] cids) panePath - lift $widgetGrabFocus (textView buf) - -clicked :: Event -> IDELog -> IDEAction -clicked (Button _ SingleClick _ _ _ _ LeftButton x y) ideLog = do - errors' <- readIDE errors - line' <- lift $ do - (x,y) <- widgetGetPointer (textView ideLog) - (_,y') <- textViewWindowToBufferCoords (textView ideLog) TextWindowWidget (x,y) - (iter,_) <- textViewGetLineAtY (textView ideLog) y' - textIterGetLine iter - case filter (\(es,_) -> fst (logLines es) <= (line'+1) && snd (logLines es) >= (line'+1)) - (zip errors' [0..(length errors')]) of - [(thisErr,n)] -> do - succ <- selectSourceBuf (filePath thisErr) - if succ - then markErrorInSourceBuf (line thisErr) (column thisErr) - (errDescription thisErr) - else return () - log :: IDELog <- getLog - lift $ markErrorInLog log (logLines thisErr) - modifyIDE_ (\ide -> return (ide{currentErr = Just n})) - otherwise -> return () -clicked _ _ = return () - - -getLog' :: IDEM IDELog -getLog' = do - mbPane <- getPane LogCasting - case mbPane of - Nothing -> do - prefs <- readIDE prefs - layout <- readIDE layout - let pp = getStandardPanePath (logPanePath prefs) layout - nb <- getNotebook pp - initLog pp nb - mbPane <- getPane LogCasting - case mbPane of - Nothing -> throwIDE "Can't init log" - Just l -> return l - Just p -> return p - -simpleLog :: String -> IDEAction -simpleLog str = do - log :: IDELog <- getLog - lift $ appendLog log str LogTag - return () - -appendLog' :: IDELog -> String -> LogTag -> IO Int -appendLog' l@(IDELog tv _) string tag = do - buf <- textViewGetBuffer tv - iter <- textBufferGetEndIter buf - textBufferSelectRange buf iter iter - textBufferInsert buf iter string - iter2 <- textBufferGetEndIter buf - case tag of - LogTag -> return () - ErrorTag -> do - len <- textBufferGetCharCount buf - strti <- textBufferGetIterAtOffset buf (len - length string) - textBufferApplyTagByName buf "err" iter2 strti - FrameTag -> do - len <- textBufferGetCharCount buf - strti <- textBufferGetIterAtOffset buf (len - length string) - textBufferApplyTagByName buf "frame" iter2 strti - textBufferMoveMarkByName buf "end" iter2 - mbMark <- textBufferGetMark buf "end" - line <- textIterGetLine iter2 - case mbMark of - Nothing -> return () - Just mark -> textViewScrollMarkOnscreen tv mark - bringPaneToFront l - return line - -markErrorInLog' :: IDELog -> (Int,Int) -> IO () -markErrorInLog' (IDELog tv _) (l1,l2) = do - buf <- textViewGetBuffer tv - iter <- textBufferGetIterAtLineOffset buf (l1-1) 0 - iter2 <- textBufferGetIterAtLineOffset buf l2 0 - textBufferSelectRange buf iter iter2 --- textBufferApplyTagByName buf "activeErr" iter iter2 - textBufferMoveMarkByName buf "end" iter - mbMark <- textBufferGetMark buf "end" - case mbMark of - Nothing -> return () - Just mark -> textViewScrollToMark tv mark 0.0 (Just (0.3,0.3)) - -clearLog' :: IDEAction -clearLog' = do - log <- getLog - buf <- lift$ textViewGetBuffer $textView log - lift $textBufferSetText buf "" - modifyIDE_ (\ide -> return (ide{errors = [], currentErr = Nothing})) - diff --git a/src/IDE/Menu.hs b/src/IDE/Menu.hs --- a/src/IDE/Menu.hs +++ b/src/IDE/Menu.hs @@ -1,11 +1,11 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} +{-# OPTIONS_GHC -XTypeSynonymInstances -XScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Menu -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL -- --- Maintainer : Juergen Nicklisch-Franken +-- Maintainer : Juergen Nicklisch-Franken -- Stability : experimental -- Portability : portable -- @@ -23,6 +23,7 @@ , aboutDialog , buildStatusbar , newIcons +, setSensitivity ) where import Graphics.UI.Gtk @@ -32,22 +33,28 @@ import Data.Version import Prelude hiding (catch) import Control.Exception +import Data.Maybe + import IDE.Core.State -import IDE.SourceEditor -import IDE.Framework.ViewFrame -import IDE.Preferences -import IDE.PackageEditor +import IDE.Pane.SourceBuffer +import IDE.Pane.Preferences +import IDE.Pane.PackageFlags +import IDE.Pane.PackageEditor import IDE.Package -import IDE.Log +import IDE.Pane.Log import IDE.SaveSession -import IDE.ModulesPane -import IDE.ToolbarPane -import IDE.FindPane -import IDE.ReplacePane -import IDE.Utils.File +import IDE.Pane.Modules +import IDE.Find +import IDE.FileUtils +import IDE.Pane.ClassHierarchy +import IDE.Pane.Search +import IDE.Pane.Callers import Paths_leksah - +import IDE.GUIHistory +import Debug.Trace +import IDE.Metainfo.Provider (rebuildLibInfo,rebuildActiveInfo) +import IDE.Pane.Info (showInfo) -- -- | The Actions known to the system (they can be activated by keystrokes or menus) -- @@ -94,8 +101,6 @@ (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 @@ -108,10 +113,20 @@ ,AD "EditShiftLeft" "Shift _Left" Nothing Nothing editShiftLeft [] False + --,AD "Align" "_Align" Nothing Nothing (return ()) [] False + ,AD "EditAlignEqual" "Align _=" Nothing Nothing + (align '=') [] False + ,AD "EditAlignRightArrow" "Align -_>" Nothing Nothing + (align '>') [] False + ,AD "EditAlignLeftArrow" "Align _<-" Nothing Nothing + (align '<') [] False + ,AD "EditAlignTypeSig" "Align _::" Nothing Nothing + (align ':') [] False + ,AD "EditCandy" "_To Candy" Nothing Nothing editCandy [] True - ,AD "Package" "Package" Nothing Nothing (return ()) [] False + ,AD "Package" "_Package" Nothing Nothing (return ()) [] False ,AD "NewPackage" "_New Package" Nothing Nothing packageNew [] False ,AD "OpenPackage" "_Open Package" Nothing Nothing @@ -121,23 +136,23 @@ ,AD "ClosePackage" "_Close Package" Nothing Nothing deactivatePackage [] False - ,AD "PackageFlags" "Edit Flags" Nothing Nothing - packageFlags [] False - ,AD "ConfigPackage" "_Configure Package" Nothing (Just "ide_configure") + ,AD "PackageFlags" "Edit Flags" (Just "Edit the package flags") Nothing + (do getFlags; return ()) [] False + ,AD "ConfigPackage" "_Configure Package" (Just "Configures the package") (Just "ide_configure") packageConfig [] False - ,AD "BuildPackage" "_Build Package" Nothing (Just "ide_make") + ,AD "BuildPackage" "_Build Package" (Just "Builds the package") (Just "ide_make") packageBuild [] False - ,AD "DocPackage" "_Build Documentation" Nothing Nothing + ,AD "DocPackage" "_Build Documentation" (Just "Builds the documentation") Nothing packageDoc [] False - ,AD "CleanPackage" "Cl_ean Package" Nothing Nothing + ,AD "CleanPackage" "Cl_ean Package" (Just "Cleans the package") Nothing packageClean [] False - ,AD "CopyPackage" "_Copy Package" Nothing Nothing + ,AD "CopyPackage" "_Copy Package" (Just "Copies the package") Nothing packageCopy [] False - ,AD "RunPackage" "_Run" Nothing (Just "ide_run") + ,AD "RunPackage" "_Run" (Just "Runs the package") (Just "ide_run") packageRun [] False - ,AD "NextError" "_Next Error" Nothing (Just "ide_error_next") + ,AD "NextError" "_Next Error" (Just "Go to the next error") (Just "ide_error_next") nextError [] False - ,AD "PreviousError" "_Previous Error" Nothing (Just "ide_error_prev") + ,AD "PreviousError" "_Previous Error" (Just "Go to the previous error") (Just "ide_error_prev") previousError [] False ,AD "InstallPackage" "_Install Package" Nothing Nothing @@ -153,6 +168,30 @@ ,AD "OpenDocPackage" "_Open Doc" Nothing Nothing packageOpenDoc [] False + ,AD "Metadata" "_Metadata" Nothing Nothing (return ()) [] False + ,AD "UpdateMetadataCurrent" "_Update Project" Nothing Nothing + rebuildActiveInfo [] False + ,AD "UpdateMetadataLib" "_Update Lib" Nothing Nothing + rebuildLibInfo [] False + ,AD "ShowModules" "Show Modules" Nothing Nothing + showModules [] False + ,AD "ShowCallers" "Show Callers" Nothing Nothing + showCallers [] False + ,AD "ShowClasses" "Show Classes" Nothing Nothing + showClasses [] False + ,AD "ShowSearch" "Show Search" Nothing Nothing + showSearch [] False + ,AD "ShowInfo" "Show Info" Nothing Nothing + showInfo [] False + + ,AD "Session" "_Session" Nothing Nothing (return ()) [] False + ,AD "SaveSession" "_Save Session" Nothing Nothing + saveSessionAsPrompt [] False + ,AD "LoadSession" "_Load Session" Nothing Nothing + loadSessionPrompt [] False + ,AD "ForgetSession" "_Forget Session" Nothing Nothing + (return ()) [] True + ,AD "View" "_View" Nothing Nothing (return ()) [] False ,AD "ViewMoveLeft" "Move _Left" Nothing Nothing (viewMove LeftP) [] False @@ -183,18 +222,16 @@ ,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 "ViewHistoryBack" "Back" Nothing (Just "gtk-go-back") + historyBack [] False + ,AD "ViewHistoryForth" "Forward" Nothing (Just "gtk-go-forward") + historyForward [] False + ,AD "ClearLog" "_Clear Log" Nothing Nothing + clearLog [] False + ,AD "ToggleToolbar" "Toggle Toolbar" Nothing Nothing + toggleToolbar [] False ,AD "Help" "_Help" Nothing Nothing (return ()) [] False ,AD "PrefsEdit" "_Edit Prefs" Nothing Nothing @@ -211,47 +248,45 @@ menuDescription :: IO String menuDescription = do prefsPath <- getConfigFilePathForLoad "Default.menu" - res <- readFile prefsPath + res <- trace ("read from path : " ++ prefsPath) $ 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 +makeMenu uiManager actions menuDescription = reifyIDE (\ideR session -> do + actionGroupGlobal <- actionGroupNew "global" + mapM_ (actm ideR session actionGroupGlobal) actions + uiManagerInsertActionGroup uiManager actionGroupGlobal 1 + uiManagerAddUiFromString uiManager menuDescription + accGroup <- uiManagerGetAccelGroup uiManager + mbWidgets <- mapM (uiManagerGetWidget uiManager) ["ui/menubar","ui/toolbar"] + let widgets = map (\mb -> case mb of Just it -> it Nothing -> throwIDE "Menu>>makeMenu: failed to build menu") mbWidgets - return (accGroup,widgets) + return (accGroup,widgets)) where - actm ideR ag (AD name label tooltip stockId ideAction accs isToggle) = do + actm ideR session 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) + on act actionToggled (doAction ideAction ideR session accString) actionGroupAddActionWithAccel ag act acc else do act <- actionNew name label tooltip stockId - onActionActivate act (doAction ideAction ideR accString) + onActionActivate act (doAction ideAction ideR session accString) actionGroupAddActionWithAccel ag act acc - doAction ideAction ideR accStr = - runReaderT (do + doAction ideAction ideR session accStr = + handleTopExceptions (reflectIDE (do ideAction sb <- getSBSpecialKeys - lift $statusbarPop sb 1 - lift $statusbarPush sb 1 $accStr - return ()) ideR + liftIO $statusbarPop sb 1 + liftIO $statusbarPush sb 1 $accStr + return ()) ideR session) -- | Quit ide -- ### make reasonable @@ -259,27 +294,28 @@ quit :: IDEAction quit = do saveSession :: IDEAction + modifyIDE_ (\ide -> return (ide{isShuttingDown = True})) b <- fileCloseAll if b - then lift mainQuit - else return () + then liftIO mainQuit + else modifyIDE_ (\ide -> return (ide{isShuttingDown = False})) -- -- | Show the about dialog -- aboutDialog :: IDEAction -aboutDialog = lift $ do +aboutDialog = liftIO $ do d <- aboutDialogNew aboutDialogSetName d "Leksah" aboutDialogSetVersion d (showVersion version) - aboutDialogSetCopyright d "Copyright 2007 Juergen Nicklisch-Franken aka Jutaro" + aboutDialogSetCopyright d "Copyright 2007-2009 Jürgen Nicklisch-Franken" aboutDialogSetComments d $ "An integrated development environement (IDE) for the " ++ - "programming language Haskell and the Glasgow Haskell compiler" + "programming language Haskell and the Glasgow Haskell Compiler" dd <- getDataDir - license <- readFile $ dd "data" "gpl.txt" + license <- catch (readFile $ dd "LICENSE") (\ (_ :: SomeException) -> return "") aboutDialogSetLicense d $ Just license - aboutDialogSetWebsite d "code.haskell.org/leksah" - aboutDialogSetAuthors d ["Juergen Nicklisch-Franken aka Jutaro"] + aboutDialogSetWebsite d "http://leksah.org/" + aboutDialogSetAuthors d ["Jürgen Nicklisch-Franken (Jutaro)"] dialogRun d widgetDestroy d return () @@ -335,24 +371,53 @@ return hb newIcons :: IO () -newIcons = +newIcons = catch (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" + "ide_method","ide_newtype","ide_other","ide_rule","ide_run","ide_slot", + "ide_source","ide_type","leksah", "ide_reexported" ] iconFactoryAddDefault iconFactory) - (\e -> throwIDE "Can't load icons") + (\(e :: SomeException) -> getDataDir >>= \dataDir -> throwIDE ("Can't load icons from " ++ dataDir)) where loadIcon dataDir iconFactory name = do pb <- pixbufNewFromFile $ dataDir "data" (name ++ ".png") icon <- iconSetNewFromPixbuf pb iconFactoryAdd iconFactory name icon +setSensitivity :: [(SensitivityMask, Bool)] -> IDEAction +setSensitivity l = mapM_ setSensitivitySingle l + where setSensitivitySingle (sens,bool) = do + actions <- getActionsFor sens + liftIO $ mapM_ (\a -> actionSetSensitive a bool) actions +getActionsFor :: SensitivityMask -> IDEM [Action] +getActionsFor SensitivityForwardHist = getActionsFor' ["ViewHistoryForth"] +getActionsFor SensitivityBackwardHist = getActionsFor' ["ViewHistoryBack"] +getActionsFor SensitivityProjectActive = getActionsFor' + ["EditPackage", "ClosePackage", "PackageFlags", "ConfigPackage", "BuildPackage" + ,"DocPackage", "CleanPackage", "CopyPackage", "RunPackage","InstallPackage" + ,"RegisterPackage", "UnregisterPackage","TestPackage","SdistPackage" + ,"OpenDocPackage","FileCloseAll"] +getActionsFor SensitivityError = getActionsFor' ["NextError", "PreviousError"] +getActionsFor SensitivityEditor = getActionsFor' ["EditUndo", "EditRedo", "EditGotoLine" + ,"EditComment", "EditUncomment", "EditShiftLeft", "EditShiftRight"] + + +getActionsFor' :: [String] -> IDEM[Action] +getActionsFor' l = do + r <- mapM getActionFor l + return (catMaybes r) + where + getActionFor string = do + uiManager' <- readIDE uiManager + actionGroups <- liftIO $ uiManagerGetActionGroups uiManager' + res <- liftIO $ actionGroupGetAction (head actionGroups) string + when (isNothing res) $ ideMessage Normal $ "Can't find UI Action " ++ string + return res diff --git a/src/IDE/Metainfo/Info.hs b/src/IDE/Metainfo/Info.hs deleted file mode 100644 --- a/src/IDE/Metainfo/Info.hs +++ /dev/null @@ -1,391 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- --- Module : IDE.Metainfo.Info --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | This module provides the infos collected by the extractor before --- and an info pane to present some of them to the user --- ---------------------------------------------------------------------------------- - -module IDE.Metainfo.Info ( - InfoAction(..) -) where - -import System.IO -import qualified Data.Map as Map -import Config -import Control.Monad -import Control.Monad.Trans -import System.FilePath -import System.Directory -import qualified Data.Map as Map -import System.IO -import Data.List -import qualified PackageConfig as DP -import Data.Maybe -import Data.Binary -import qualified Data.ByteString.Lazy as BS -import Distribution.Package -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Map (Map) -import Data.ByteString.Char8 (ByteString) -import System.Process(ProcessHandle,getProcessExitCode) -import System.Glib.MainLoop(timeoutAddFull,priorityDefaultIdle) -import Control.Monad.Reader(runReaderT,ask) -import Distribution.Version - -import IDE.Utils.DeepSeq -import IDE.Utils.File -import IDE.Core.State -import IDE.Metainfo.InterfaceCollector - -class InfoAction alpha where - -- | Initialize metadata for the world - initInfo :: alpha - -- | Update world metadata - updateAccessibleInfo :: alpha - -- | Builds the current info for a package - -- Called when a package gets active or after a reconfigure - infoForActivePackage :: alpha - -- | Builds the current info for the activePackage in the background. - -- If a process handle is given, it waits for this process to finish before building - -- and only rebuilds if build was successful - -- Called after a build - mayRebuildInBackground :: Maybe ProcessHandle -> alpha - -- | Rebuild current info - rebuildActiveInfo :: alpha - -instance InfoAction IDEAction where - initInfo = initInfo' - updateAccessibleInfo = updateAccessibleInfo' - infoForActivePackage = infoForActivePackage' - mayRebuildInBackground = mayRebuildInBackground' - rebuildActiveInfo = setInfo buildActiveInfo - --- --- | Update and initialize metadata for the world --- -initInfo' :: IDEAction -initInfo' = do - session' <- readIDE session - ideMessage Normal "Now updating metadata ..." - lift $ collectInstalled session' False - ideMessage Normal "Now loading metadata ..." - loadAccessibleInfo - ideMessage Normal "Finished loading ..." - --- --- | Load all infos for all installed and exposed packages --- (see shell command: ghc-pkg list) --- -loadAccessibleInfo :: IDEAction -loadAccessibleInfo = - let version = cProjectVersion in do - session' <- readIDE session - - collectorPath <- lift $ getCollectorPath version - packageInfos <- lift $ getInstalledPackageInfos session' - packageList <- lift $ mapM (loadInfosForPackage collectorPath) - (map (fromDPid . DP.package) packageInfos) - let scope = foldr buildScope (Map.empty,Map.empty) - $ map fromJust - $ filter isJust packageList - modifyIDE_ (\ide -> return (ide{accessibleInfo = (Just scope)})) - --- --- | Clears the current info, not the world infos --- -clearCurrentInfo :: IDEAction -clearCurrentInfo = do - modifyIDE_ (\ide -> return (ide{currentInfo = Nothing})) - ideR <- ask - triggerEvent ideR CurrentInfo - return () - --- --- | Set info for package --- -infoForActivePackage' :: IDEAction -infoForActivePackage' = do - activePack <- readIDE activePack - case activePack of - Nothing -> do - modifyIDE_ (\ide -> return (ide{currentInfo = Nothing})) - Just pack -> do - let depends' = depends pack - session' <- readIDE session - fp <- lift $findFittingPackages session' depends' - mbActive <- loadOrBuildActiveInfo - case mbActive of - Nothing -> do - -- no meta info available - modifyIDE_ (\ide -> return (ide{currentInfo = Nothing})) - Just active -> do - - accessibleInfo' <- readIDE accessibleInfo - case accessibleInfo' of - Nothing -> modifyIDE_ (\ide -> return (ide{currentInfo = Nothing})) - Just (pdmap,_) -> do - let packageList = map (\ pin -> pin `Map.lookup` pdmap) fp - let scope = foldr buildScope (Map.empty,Map.empty) - $ map fromJust - $ filter isJust packageList - modifyIDE_ (\ide -> return (ide{currentInfo = Just (active, scope)})) - ideR <- ask - triggerEvent ideR CurrentInfo - return () - - --- --- | Builds the current info for the activePackage in the background --- If a process handle is given, it waits for this process to finish before building --- -mayRebuildInBackground' :: Maybe ProcessHandle -> IDEAction -mayRebuildInBackground' mbHandle = do - ideR <- ask - lift $ do - timeoutAddFull (myRebuild ideR) priorityDefaultIdle 500 - return () - where - myRebuild :: IDERef -> IO Bool - myRebuild ideR = - case mbHandle of - Just hdl -> do - mbExitCode <- getProcessExitCode hdl - case mbExitCode of - --process not finished, wait for next call - Nothing -> return True - Just _ -> doIt ideR - Nothing -> doIt ideR - doIt :: IDERef -> IO Bool - doIt ideR = do - runReaderT (do - errs <- readIDE errors - when (length (filter isError errs) == 0) $ do - ideMessage Normal "Update meta info for active package" - setInfo buildActiveInfo) ideR - return False - --- --- | Builds the current info for the activePackage --- -setInfo :: IDEM (Maybe PackageScope) -> IDEAction -setInfo f = do - currentInfo <- readIDE currentInfo - case currentInfo of - Nothing -> return () - Just (active, scope) -> do - newActive <- f - case newActive of - Nothing -> return () - Just newActive -> do - modifyIDE_ (\ide -> return (ide{currentInfo = Just (newActive, scope)})) - ideR <- ask - triggerEvent ideR CurrentInfo - return () - --- --- | Loads the current info for the activePackage, or builds it if not available --- -loadOrBuildActiveInfo :: IDEM (Maybe PackageScope) -loadOrBuildActiveInfo = do - mbActiveInfo <- loadActiveInfo - case mbActiveInfo of - Just ai -> return (Just ai) - Nothing -> buildActiveInfo - --- --- | Loads the current info for the activePackage --- -loadActiveInfo :: IDEM (Maybe PackageScope) -loadActiveInfo = - let version = cProjectVersion in do - activePack <- readIDE activePack - session <- readIDE session - case activePack of - Nothing -> return Nothing - Just idePackage -> do - collectorPath <- lift $ getCollectorPath cProjectVersion - packageDescr <- lift $ loadInfosForPackage collectorPath - (packageId idePackage) - case packageDescr of - Nothing -> return Nothing - Just pd -> do - let scope = buildScope pd (Map.empty,Map.empty) - return (Just scope) - --- --- | Builds the current info for the activePackage --- -buildActiveInfo :: IDEM (Maybe PackageScope) -buildActiveInfo = - let version = cProjectVersion in do - activePack <- readIDE activePack - session <- readIDE session - case activePack of - Nothing -> return Nothing - Just idePackage -> do - lift $ collectUninstalled False session cProjectVersion (cabalFile idePackage) - -- ideMessage Normal "uninstalled collected" - collectorPath <- lift $ getCollectorPath cProjectVersion - packageDescr <- lift $ loadInfosForPackage collectorPath - (packageId idePackage) - case packageDescr of - Nothing -> return Nothing - Just pd -> do - let scope = buildScope pd (Map.empty,Map.empty) - return (Just scope) - --- --- | Updates the world info (it is the responsibility of the caller to rebuild --- the current info) --- -updateAccessibleInfo' :: IDEAction -updateAccessibleInfo' = do - wi <- readIDE accessibleInfo - session <- readIDE session - let version = cProjectVersion - case wi of - Nothing -> loadAccessibleInfo - Just (psmap,psst) -> do - packageInfos <- lift $ getInstalledPackageInfos session - let packageIds = map (fromDPid . DP.package) packageInfos - let newPackages = filter (\ pi -> Map.member pi psmap) packageIds - let trashPackages = filter (\ e -> not (elem e packageIds))(Map.keys psmap) - if null newPackages && null trashPackages - then return () - else do - collectorPath <- lift $ getCollectorPath version - newPackageInfos <- lift $ mapM (\pid -> loadInfosForPackage collectorPath pid) - newPackages - let psamp2 = foldr (\e m -> Map.insert (packagePD e) e m) - psmap - (map fromJust - $ filter isJust newPackageInfos) - let psamp3 = foldr (\e m -> Map.delete e m) psmap trashPackages - let scope = foldr buildScope (Map.empty,Map.empty) - (Map.elems psamp3) - modifyIDE_ (\ide -> return (ide{accessibleInfo = Just scope})) - --- --- | Loads the infos for the given packages --- -loadInfosForPackage :: FilePath -> PackageIdentifier -> IO (Maybe PackageDescr) -loadInfosForPackage dirPath pid = do - let filePath = dirPath showPackageId pid ++ ".pack" - exists <- doesFileExist filePath - if exists - then catch (do - file <- openBinaryFile filePath ReadMode - bs <- BS.hGetContents file - let packageInfo = decode bs - packageInfo `deepSeq` (hClose file) - return (Just packageInfo)) - (\e -> do sysMessage Normal (show e); return Nothing) - else do - sysMessage Normal $"packageInfo not found for " ++ showPackageId pid - return Nothing - --- --- | Loads the infos for the given packages (has an collecting argument) --- -buildScope :: PackageDescr -> PackageScope -> PackageScope -buildScope packageD (packageMap, symbolTable) = - let pid = packagePD packageD - in if pid `Map.member` packageMap - then (packageMap, symbolTable) - else (Map.insert pid packageD packageMap, - buildSymbolTable packageD symbolTable) - -buildSymbolTable :: PackageDescr -> SymbolTable -> SymbolTable -buildSymbolTable pDescr symbolTable = - foldl (\ st idDescr -> let allIds = identifierID idDescr : (allConstructorsID idDescr - ++ allFieldsID idDescr ++ allClassOpsID idDescr) - in foldl (\ st2 id -> Map.insertWith (++) id [idDescr] st2) st allIds) - symbolTable (idDescriptionsPD pDescr) - - - --- --------------------------------------------------------------------- --- DeepSeq instances for forcing evaluation --- - -instance DeepSeq Location where - deepSeq pd = deepSeq (locationSLine pd) - $ deepSeq (locationSCol pd) - $ deepSeq (locationELine pd) - $ deepSeq (locationECol pd) - -instance DeepSeq PackageDescr where - deepSeq pd = deepSeq (packagePD pd) - $ deepSeq (mbSourcePathPD pd) - $ deepSeq (exposedModulesPD pd) - $ deepSeq (buildDependsPD pd) - $ deepSeq (idDescriptionsPD pd) - -instance DeepSeq ModuleDescr where - deepSeq pd = deepSeq (moduleIdMD pd) - $ deepSeq (mbSourcePathMD pd) - $ deepSeq (exportedNamesMD pd) - $ deepSeq (usagesMD pd) - -instance DeepSeq IdentifierDescr where - deepSeq (SimpleDescr identifierID' identifierTypeID' typeInfoID' moduleIdID' - mbLocation' mbComment') = deepSeq identifierID' - $ deepSeq identifierTypeID' - $ deepSeq typeInfoID' - $ deepSeq moduleIdID' - $ deepSeq mbLocation' - $ deepSeq mbComment' - deepSeq (DataDescr identifierID' typeInfoID' moduleIdID' constructorsID' fieldsID' - mbLocation' mbComment') = deepSeq identifierID' - $ deepSeq typeInfoID' - $ deepSeq moduleIdID' - $ deepSeq constructorsID' - $ deepSeq fieldsID' - $ deepSeq mbLocation' - $ deepSeq mbComment' - deepSeq (ClassDescr identifierID' typeInfoID' classOpsID' moduleIdID' - mbLocation' mbComment') = deepSeq identifierID' - $ deepSeq typeInfoID' - $ deepSeq moduleIdID' - $ deepSeq classOpsID' - $ deepSeq mbLocation' - $ deepSeq mbComment' - deepSeq (InstanceDescr identifierID' classID' moduleIdID' - mbLocation' mbComment') = deepSeq identifierID' - $ deepSeq classID' - $ deepSeq moduleIdID' - $ deepSeq mbLocation' - $ deepSeq mbComment' - -instance DeepSeq PackageIdentifier where - deepSeq pd = deepSeq (pkgName pd) - $ deepSeq (pkgVersion pd) - -instance DeepSeq alpha => DeepSeq (Set alpha) where - deepSeq s = deepSeq (Set.elems s) - -instance (DeepSeq alpha, DeepSeq beta) => DeepSeq (Map alpha beta) where - deepSeq s = deepSeq (Map.toList s) - -instance DeepSeq IdType where deepSeq = seq - -instance DeepSeq IdTypeS where deepSeq = seq - -instance DeepSeq ByteString where deepSeq = seq - -instance DeepSeq Version where deepSeq = seq - -instance DeepSeq PackModule where - deepSeq pd = deepSeq (pack pd) - $ deepSeq (modu pd) - diff --git a/src/IDE/Metainfo/InterfaceCollector.hs b/src/IDE/Metainfo/InterfaceCollector.hs --- a/src/IDE/Metainfo/InterfaceCollector.hs +++ b/src/IDE/Metainfo/InterfaceCollector.hs @@ -1,11 +1,11 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} +{-# OPTIONS_GHC -XScopedTypeVariables -XFlexibleContexts#-} ----------------------------------------------------------------------------- -- -- Module : IDE.Metainfo.InterfaceCollector -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL -- --- Maintainer : Juergen Nicklisch-Franken +-- Maintainer : Juergen Nicklisch-Franken -- Stability : experimental -- Portability : portable -- @@ -19,18 +19,18 @@ , collectInstalled' , collectUninstalled , getInstalledPackageInfos -, asDPid -, fromDPid , findFittingPackages +, metadataVersion ) where -import GHC hiding(Id,Failed,Succeeded) -import Module -import TcRnMonad +import GHC hiding(Id,Failed,Succeeded,ModuleName) +import Module hiding (PackageId,ModuleName) +import qualified Module +import TcRnMonad hiding (liftIO,MonadIO) import qualified Maybes as M -import HscTypes +import HscTypes hiding (liftIO) import LoadIface import Outputable hiding(trace) import IfaceSyn @@ -39,16 +39,20 @@ import qualified PackageConfig as DP import Name import PrelNames -import PackageConfig(mainPackageId,unpackPackageId,mkPackageId) +import PackageConfig(unpackPackageId,mkPackageId) import Maybes import TcRnTypes import Finder import qualified FastString as FS import ErrUtils import Config(cProjectVersion) -import UniqFM +import Distribution.PackageDescription.Parse(readPackageDescription) +import Distribution.PackageDescription.Configuration(flattenPackageDescription) +import qualified IOEnv as IOEnv (liftIO,MonadIO) +import IOEnv hiding (liftIO,MonadIO) -import Data.List (maximumBy) +import Debug.Trace + import Data.Char (isSpace) import qualified Data.Map as Map import Data.Map (Map) @@ -56,12 +60,13 @@ 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 qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Package hiding (PackageId) import Distribution.Verbosity import Distribution.Version +import Distribution.ModuleName +import Distribution.Text (simpleParse,display) import Control.Monad.Reader import System.IO import Data.Maybe @@ -71,13 +76,15 @@ 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 Default +import IDE.Core.State hiding (depends) +import IDE.FileUtils +--import IDE.Metainfo.Provider import IDE.Metainfo.SourceCollector +metadataVersion :: Integer +metadataVersion = 3 + data CollectStatistics = CollectStatistics { packagesTotal :: Int , packagesWithSource :: Int @@ -92,167 +99,195 @@ collectInstalledI :: Bool -> IDEAction collectInstalledI b = do - session' <- readIDE session - sources <- lift $ getSourcesMap - lift $ collectInstalled' False session' cProjectVersion b sources + session' <- lift $ getSession + sources <- liftIO $ getSourcesMap + lift $ collectInstalled' False cProjectVersion b sources -collectInstalled :: Session -> Bool -> IO () +collectInstalled :: HscEnv -> Bool -> Ghc () collectInstalled session b = do - sources <- getSourcesMap - collectInstalled' False session cProjectVersion b sources + sources <- liftIO $ getSourcesMap + collectInstalled' False 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 +collectInstalled' :: Bool -> String -> Bool -> Map PackageIdentifier [FilePath] -> Ghc() +collectInstalled' writeAscii version forceRebuild sources = do + session <- getSession + setTargets [] + load LoadAllTargets + depanal [] False + collectorPath <- liftIO $ getCollectorPath version + when forceRebuild $ liftIO $ 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 <- liftIO $ findKnownPackages collectorPath + packageInfos <- getInstalledPackageInfos + let newPackages = filter (\pi -> not $Set.member (fromPackageIdentifier $ IPI.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 + exportedIfaceInfos <- mapM (\ info -> getIFaceInfos (mkPackageId $ IPI.package info) + (IPI.exposedModules info) session) newPackages + hiddenIfaceInfos <- mapM (\ info -> getIFaceInfos (mkPackageId $ IPI.package info) + (IPI.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 + (map IPI.package newPackages) + (map depends newPackages) + (packagesWithSource', modulesTotal', modulesWithSource', parseFailures') + <- foldM (\ (pws,mt,ms,failed) pdescr -> do + (pdescr, num) <- collectSources sources pdescr + writeExtracted collectorPath writeAscii False pdescr + let pws' = pws + if isJust (mbSourcePathPD pdescr) + then 1 + else 0 + let mt' = mt + (length . exposedModulesPD) pdescr + let ms' = ms + if isJust (mbSourcePathPD pdescr) + then (length . exposedModulesPD) pdescr + else 0 + return (pws',mt',ms',failed + num)) + (0,0,0,0) 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 + packagesTotal = length extracted + , packagesWithSource = packagesWithSource' + , modulesTotal = modulesTotal' + , modulesWithSource = modulesWithSource' + , parseFailures = parseFailures'} + liftIO $ 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 +collectUninstalled :: Bool -> String -> FilePath -> Ghc () +collectUninstalled writeAscii version cabalPath = do + setTargets [] + load LoadAllTargets + depanal [] False + pd <- liftIO $ readPackageDescription normal cabalPath >>= return . flattenPackageDescription + let packageName = if hasExes pd + then "main" + else show $ package pd 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 + cCabalPath <- liftIO $ canonicalizePath cabalPath + let basePath = takeDirectory cCabalPath + let buildPath = if hasExes pd + then let exeName' = exeName (head (executables pd)) + in "dist" "build" exeName' + exeName' ++ "-tmp" "" + else "dist" "build" "" + trace ("basePath = " ++ basePath) (return ()) + trace ("buildPath = " ++ buildPath) (return ()) + + dflags0 <- getSessionDynFlags + setSessionDynFlags dflags0 - { topDir = basePath - , importPaths = [buildPath] - --, thisPackage = mkPackageId (package pd) - , ghcMode = OneShot + { topDir = basePath + , importPaths = [buildPath,"dist" "build" "autogen"] + , thisPackage = if hasExes pd then mainPackageId else 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) + dflags1 <- getSessionDynFlags + (dflags2,_,_) <- parseDynamicFlags dflags1 [(noLoc "-fglasgow-exts")] + setSessionDynFlags dflags2 +-- trace ("modules = " ++ show modules) (return ()) + let ghcmodules = map (mkModuleName . display) modules + allIfaceInfos <- getIFaceInfos2 ghcmodules packageName + deps <- findFittingPackages (buildDepends pd) + let extracted = extractInfo (allIfaceInfos, [], package pd, deps) +-- trace ("extracted = " ++ show extracted) (return ()) let sources = Map.fromList [(package pd,[cabalPath])] - (extractedWithSources,_) <- collectSources session sources extracted + (extractedWithSources,_) <- collectSources sources extracted collectorPath <- getCollectorPath version - writeExtracted collectorPath writeAscii extractedWithSources - writeExtracted collectorPath True extractedWithSources + writeExtracted collectorPath writeAscii True extractedWithSources sysMessage Normal $ "\nExtracted infos for " ++ cabalPath ------------------------------------------------------------------------- -getIFaceInfos :: PackageId -> [String] -> Session -> IO [(ModIface, FilePath)] +getIFaceInfos :: PackageId -> [Module.ModuleName] -> HscEnv -> Ghc [(ModIface, FilePath)] getIFaceInfos pckg modules session = case unpackPackageId pckg of Nothing -> return [] Just pid -> do - let isBase = pkgName pid == "base" + let isBase = pkgName pid == (PackageName "base") let ifaces = mapM (\ mn -> findAndReadIface empty (if isBase - then mkBaseModule_ (mkModuleName mn) - else mkModule pckg - (mkModuleName mn)) + then mkBaseModule_ mn + else mkModule pckg mn) False) modules - hscEnv <- sessionHscEnv session + hscEnv <- getSession let gblEnv = IfGblEnv { if_rec_types = Nothing } - maybes <- initTcRnIf 'i' hscEnv gblEnv () ifaces + maybes <- liftIO $ 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 +getIFaceInfos2 :: [Module.ModuleName] -> String -> Ghc [(ModIface, FilePath)] +getIFaceInfos2 modules packageName = do + session <- getSession + let ifaces = mapM (\ mn -> findAndReadIface2 session mn + (mkModule (stringToPackageId packageName) mn)) modules let gblEnv = IfGblEnv { if_rec_types = Nothing } - maybes <- initTcRnIf 'i' hscEnv gblEnv () ifaces + maybes <- liftIO $ initTcRnIf 'i' session gblEnv () ifaces let res = catMaybes (map handleErr maybes) return res where handleErr (M.Succeeded val) = Just val - handleErr (M.Failed mess) = Nothing + handleErr (M.Failed mess) = trace ("failed !!!" ++ showSDoc 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) +findAndReadIface2 :: HscEnv -> Module.ModuleName -> Module -> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath)) +findAndReadIface2 session doc mod = do + mb_found <- IOEnv.liftIO $ findHomeModule session doc case mb_found of Found loc mod -> do let file_path = ml_hi_file loc - read_result <- readIface mod file_path False + filePath <- IOEnv.liftIO $ canonicalizePath file_path + read_result <- readIface mod filePath False case read_result of - Failed _ -> returnM (Failed (text $ "can't read iface " ++ - doc ++ " at " ++ file_path)) + Failed mess -> return (Failed (text $ "can't read iface " ++ + moduleNameString doc ++ " at " ++ filePath ++ " " ++ showSDoc mess)) Succeeded iface | mi_module iface /= mod - -> return (Failed (text $ "read but not equal" ++ doc)) + -> return (Failed (text $ "read but not equal" ++ moduleNameString doc)) | otherwise - -> returnM (Succeeded (iface, file_path)) - _ -> return (Failed (text $ "can't locate " ++ doc)) + -> return (Succeeded (iface, filePath)) + _ -> return (Failed (text $ "can't locate " ++ moduleNameString 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) + let allDescrs = concatMap (extractExportedDescrH pi) + (map fst (ifacesHid ++ ifacesExp)) + mods = map (extractExportedDescrR pi allDescrs) (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 +extractExportedDescrH :: PackageIdentifier -> ModIface -> [Descr] +extractExportedDescrH pid iface = + let mid = (fromJust . simpleParse . 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)) - in foldr (extractIdentifierDescr' pid []) amap exportedDecls + in concatMap (extractIdentifierDescr pid [mid]) exportedDecls extractExportedDescrR :: PackageIdentifier - -> SymbolTable + -> [Descr] -> ModIface -> ModuleDescr extractExportedDescrR pid hidden iface = - let mid = moduleNameString $moduleName (mi_module iface) + let mid = (fromJust . simpleParse . moduleNameString . moduleName) (mi_module iface) exportedNames = Set.fromList $map occNameString $concatMap availNames @@ -261,11 +296,9 @@ `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 + otherDecls = exportedNames `Set.difference` (Set.fromList (map descrName ownDecls)) + reexported = map (\d -> Reexported (PM pid mid) d) + $ filter (\k -> (descrName k) `Set.member` otherDecls) hidden inst = concatMap (extractInstances (PM pid mid)) (mi_insts iface) uses = Map.fromList $ map extractUsages (mi_usages iface) in ModuleDescr { @@ -273,126 +306,118 @@ , 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 + , idDescriptionsMD = ownDecls ++ inst ++ reexported} -extractIdentifierDescr :: PackageIdentifier -> [ModuleIdentifier] -> IfaceDecl - -> [IdentifierDescr] +extractIdentifierDescr :: PackageIdentifier -> [ModuleName] -> IfaceDecl + -> [Descr] extractIdentifierDescr package modules decl - = if null modules - then [] - else case decl of + = if null modules + then [] + else + let descr = Descr{ + descrName' = unpackFS $occNameFS (ifName decl) + , typeInfo' = BS.pack $ filterExtras $ showSDocUnqual $ppr decl + , descrModu' = PM package (last modules) + , mbLocation' = Nothing + , mbComment' = Nothing + , details' = VariableDescr + } + in 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 - }] + -> [descr] + (IfaceData name _ _ ifCons _ _ _ _) + -> let d = case ifCons of + IfDataTyCon decls + -> let + fieldNames = concatMap extractFields (visibleIfConDecls ifCons) + constructors' = extractConstructors name (visibleIfConDecls ifCons) + in DataDescr{ + fields = fieldNames, + constructors = constructors'} + IfNewTyCon _ + -> let + fieldNames = concatMap extractFields (visibleIfConDecls ifCons) + constructors' = extractConstructors name (visibleIfConDecls ifCons) + mbField = case fieldNames of + [] -> Nothing + [fn] -> Just fn + _ -> error $ "InterfaceCollector >> extractIdentifierDescr: " + ++ "Newtype with more then one field" + constructor = case constructors' of + [c] -> c + _ -> error $ "InterfaceCollector >> extractIdentifierDescr: " + ++ "Newtype with not exactly one constructor" + in NewtypeDescr constructor mbField + IfAbstractTyCon -> DataDescr [] [] + IfOpenDataTyCon -> DataDescr [] [] + in [descr{details' = d}] + (IfaceClass context _ _ _ _ ifSigs _ ) + -> let + classOpsID = map extractClassOp ifSigs + superclasses = extractSuperClassNames context + in [descr{details' = ClassDescr{super = superclasses, + methods = classOpsID}}] (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 - }] + -> [descr] (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 - }] + -> [descr] -extractConstructorName :: IfaceConDecl -> Symbol -extractConstructorName decl = unpackFS $occNameFS (ifConOcc decl) +extractConstructors :: OccName -> [IfaceConDecl] -> [(Symbol,TypeInfo)] +extractConstructors name decls = map (\decl -> (unpackFS $occNameFS (ifConOcc decl), + (BS.pack $ filterExtras $ showSDocUnqual $ + pprIfaceForAllPart (ifConUnivTvs decl ++ ifConExTvs decl) + (eq_ctxt decl ++ ifConCtxt decl) (pp_tau decl)))) decls + where + pp_tau decl = case map pprParendIfaceType (ifConArgTys decl) ++ [pp_res_ty decl] of + (t:ts) -> fsep (t : map (arrow <+>) ts) + [] -> panic "pp_con_taus" + pp_res_ty decl = ppr name <+> fsep [ppr tv | (tv,_) <- ifConUnivTvs decl] + eq_ctxt decl = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty) + | (tv,ty) <- ifConEqSpec decl] -extractFieldNames :: IfaceConDecl -> [Symbol] -extractFieldNames decl = map (extractFieldNames') (ifConFields decl) +extractFields :: IfaceConDecl -> [(Symbol,TypeInfo)] +extractFields decl = zip (map extractFieldNames (ifConFields decl)) + (map extractType (ifConArgTys decl)) -extractFieldNames' :: OccName -> Symbol -extractFieldNames' occName = unpackFS $occNameFS occName +extractType :: IfaceType -> TypeInfo +extractType decl = BS.pack $ filterExtras $ showSDocUnqual $ppr decl -extractClassOpName :: IfaceClassOp -> Symbol -extractClassOpName (IfaceClassOp occName _ _) = unpackFS $occNameFS occName +extractFieldNames :: OccName -> Symbol +extractFieldNames occName = unpackFS $occNameFS occName -extractInstances :: PackModule -> IfaceInst -> [IdentifierDescr] +extractClassOp :: IfaceClassOp -> (Symbol, TypeInfo) +extractClassOp (IfaceClassOp occName dm ty) = (unpackFS $occNameFS occName, + BS.pack $ showSDocUnqual (ppr ty)) + +extractSuperClassNames :: [IfacePredType] -> [Symbol] +extractSuperClassNames l = catMaybes $ map extractSuperClassName l + where extractSuperClassName (IfaceClassP name _) = + Just (unpackFS $occNameFS $ nameOccName name) + extractSuperClassName _ = Nothing + +extractInstances :: PackModule -> IfaceInst -> [Descr] 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}] + in [Descr + { descrName' = className + , typeInfo' = BS.empty + , descrModu' = pm + , mbLocation' = Nothing + , mbComment' = Nothing + , details' = InstanceDescr {binds = dataNames}}] -extractUsages :: Usage -> (ModuleIdentifier, Set Symbol) -extractUsages usage = - let name = (showSDoc . ppr) $ usg_name usage - ids = map (showSDocUnqual . ppr . fst) $ usg_entities usage + +extractUsages :: Usage -> (ModuleName, Set Symbol) +extractUsages (UsagePackageModule usg_mod _ ) = + let name = (fromJust . simpleParse . moduleNameString) (moduleName usg_mod) + in (name, Set.fromList []) +extractUsages (UsageHomeModule usg_mod_name _ usg_entities _) = + let name = (fromJust . simpleParse . moduleNameString) usg_mod_name + ids = map (showSDocUnqual . ppr . fst) usg_entities in (name, Set.fromList ids) filterExtras, filterExtras' :: String -> String @@ -422,49 +447,13 @@ | otherwise = skipNextWord' r skipNextWord' [] = [] -writeExtracted :: FilePath -> Bool -> PackageDescr -> IO () -writeExtracted dirPath writeAscii pd = do - let filePath = dirPath showPackageId (packagePD pd) ++ ".pack" +writeExtracted :: MonadIO m => FilePath -> Bool -> Bool -> PackageDescr -> m () +writeExtracted dirPath writeAscii isWorkingPackage pd = liftIO $ do + let filePath = dirPath fromPackageIdentifier (packagePD pd) ++ + (if isWorkingPackage then ".packw" else ".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 + else encodeFile filePath (metadataVersion, pd) -- --------------------------------------------------------------------- -- Binary Instances for linear storage @@ -524,87 +513,95 @@ 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 +instance Binary Descr where + put (Descr descrName2 typeInfo2 descrModu2 mbLocation2 mbComment2 details2) + = do put (1:: Int) + put descrName2 + put typeInfo2 + put descrModu2 + put mbLocation2 + put mbComment2 + put details2 + put (Reexported reexpModu' impDescr') + = do put (2:: Int) + put reexpModu' + put impDescr' + 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') + descrName2 <- get + typeInfo2 <- get + descrModu2 <- get + mbLocation2 <- get + mbComment2 <- get + details2 <- get + return (Descr descrName2 typeInfo2 descrModu2 mbLocation2 + mbComment2 details2) 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" + reexpModu' <- get + impDescr' <- get + return (Reexported reexpModu' impDescr') + _ -> throwIDE "Impossible in Binary Descr get" +instance Binary SpDescr where + put VariableDescr + = do put (1:: Int) + put (FieldDescr typeDescrF') + = do put (2:: Int) + put typeDescrF' + put (ConstructorDescr typeDescrC') + = do put (3:: Int) + put typeDescrC' + put (DataDescr constructors' fields') + = do put (4:: Int) + put constructors' + put fields' + put TypeDescr + = do put (5:: Int) + put (NewtypeDescr constructor' mbField') + = do put (6:: Int) + put constructor' + put mbField' + put (ClassDescr super' methods') + = do put (7:: Int) + put super' + put methods' + put (MethodDescr classDescrM') + = do put (8:: Int) + put classDescrM' + put (InstanceDescr binds') + = do put (9:: Int) + put binds' -instance Binary IdTypeS where - put it = do put (fromEnum it) - get = do code <- get - return (toEnum code) + get = do (typeHint :: Int) <- get + case typeHint of + 1 -> return VariableDescr + 2 -> do + typeDescrF' <- get + return (FieldDescr typeDescrF') + 3 -> do + typeDescrC' <- get + return (ConstructorDescr typeDescrC') + 4 -> do + constructors' <- get + fields' <- get + return (DataDescr constructors' fields') + 5 -> return TypeDescr + 6 -> do + constructor' <- get + mbField' <- get + return (NewtypeDescr constructor' mbField') + 7 -> do + super' <- get + methods' <- get + return (ClassDescr super' methods') + 8 -> do + classDescrM' <- get + return (MethodDescr classDescrM') + 9 -> do + binds' <- get + return (InstanceDescr binds') + _ -> throwIDE "Impossible in Binary SpDescr get" instance Binary Location where put (Location locationSLine' locationSCol' locationELine' locationECol') @@ -618,4 +615,11 @@ locationECol' <- get return (Location locationSLine' locationSCol' locationELine' locationECol') +instance Binary ModuleName where + put = put . display + get = liftM (fromJust . simpleParse) get + +instance Binary PackageName where + put (PackageName pn) = put pn + get = liftM PackageName get diff --git a/src/IDE/Metainfo/Provider.hs b/src/IDE/Metainfo/Provider.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Metainfo/Provider.hs @@ -0,0 +1,504 @@ +{-# OPTIONS_GHC -XTypeSynonymInstances -XScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Metainfo.Provider +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | This module provides the infos collected by the extractor before +-- and an info pane to present some of them to the user +-- +--------------------------------------------------------------------------------- + +module IDE.Metainfo.Provider ( + initInfo +, updateAccessibleInfo +, infoForActivePackage +, mayRebuildInBackground +, rebuildActiveInfo +, searchMeta +, rebuildLibInfo +) 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 hiding (depends,packageId) +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(ask) +import Distribution.Version +import Distribution.ModuleName +import GHC (runGhc,getSession) + +import DeepSeq +import IDE.FileUtils +import IDE.Core.State +import IDE.Metainfo.InterfaceCollector +import Control.Event +import Data.Char (toLower,isUpper,toUpper,isLower) +import Text.Regex.Posix +import System.IO.Unsafe (unsafePerformIO) +import Text.Regex.Posix.String (execute,compile) + +-- +-- | Searching of metadata +-- +searchMeta :: Scope -> String -> SearchMode -> IDEM [Descr] +searchMeta Local searchString searchType = do + currentInfo' <- readIDE currentInfo + case currentInfo' of + Nothing -> return [] + Just (l,_) -> return (searchInScope searchType searchString (snd l)) +searchMeta Package searchString searchType = do + currentInfo' <- readIDE currentInfo + case currentInfo' of + Nothing -> return [] + Just (l,p) -> return (searchInScope searchType searchString (snd l) + ++ searchInScope searchType searchString (snd p)) +searchMeta System searchString searchType = do + accessibleInfo' <- readIDE accessibleInfo + let s = case accessibleInfo' of + Nothing -> Map.empty + Just (_,scope) -> scope + currentInfo' <- readIDE currentInfo + case currentInfo' of + Nothing -> return (searchInScope searchType searchString s) + Just (l,_) -> return (searchInScope searchType searchString (snd l) + ++ searchInScope searchType searchString s) + + +searchInScope :: SearchMode -> String -> SymbolTable -> [Descr] +searchInScope (Exact _) l st = searchInScopeExact l st +searchInScope (Prefix True) l st = (concat . Map.elems) (searchInScopePrefix l st) +searchInScope (Prefix False) [] _ = [] +searchInScope (Prefix False) l st = (concat . Map.elems) (searchInScopeCaseIns l st "") +searchInScope (Regex b) l st = searchRegex l st b + + +searchInScopeExact :: String -> SymbolTable -> [Descr] +searchInScopeExact searchString symbolTable = + case Map.lookup searchString symbolTable of + Nothing -> [] + Just l -> l + +searchInScopePrefix :: String -> SymbolTable -> SymbolTable +searchInScopePrefix searchString symbolTable = + let (_, exact, mapR) = Map.splitLookup searchString symbolTable + (mbL, _, _) = Map.splitLookup (searchString ++ "{") mapR + in case exact of + Nothing -> mbL + Just e -> Map.insert searchString e mbL + +searchInScopeCaseIns :: String -> SymbolTable -> String -> SymbolTable +searchInScopeCaseIns [] st _ = st +searchInScopeCaseIns (a:l) st pre | isLower a = + let s1 = pre ++ [a] + s2 = pre ++ [toUpper a] + in (Map.union (searchInScopeCaseIns l (searchInScopePrefix s1 st) s1) + (searchInScopeCaseIns l (searchInScopePrefix s2 st) s2)) + | isUpper a = + let s1 = pre ++ [a] + s2 = pre ++ [toLower a] + in (Map.union (searchInScopeCaseIns l (searchInScopePrefix s1 st) s1) + (searchInScopeCaseIns l (searchInScopePrefix s2 st) s2)) + | otherwise = + let s = pre ++ [a] + in searchInScopeCaseIns l (searchInScopePrefix s st) s + +searchRegex :: String -> SymbolTable -> Bool -> [Descr] +searchRegex searchString st caseSense = + unsafePerformIO $ do + res <- compile (if caseSense then compBlank else compIgnoreCase) + execBlank searchString + case res of + Left err -> do + sysMessage Normal (show err) + return [] + Right regex -> + filterM (\e -> do + res <- execute regex (descrName e) + case res of + Left e -> return False + Right Nothing -> return False + _ -> return True) + (concat (Map.elems st)) + +-- +-- | Update and initialize metadata for the world +-- +initInfo :: IDEAction +initInfo = do + prefs <- readIDE prefs + session' <- lift getSession + when (collectAtStart prefs) $ do + 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 + collectorPath <- lift $ getCollectorPath version + packageInfos <- lift $ getInstalledPackageInfos + packageList <- liftIO $ mapM (loadInfosForPackage collectorPath False) + (map 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 + fp <- lift $findFittingPackages 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 = reifyIDE $ \ ideR session -> + let + myRebuild :: IO Bool + myRebuild = + case mbHandle of + Just hdl -> do + mbExitCode <- getProcessExitCode hdl + case mbExitCode of + --process not finished, wait for next call + Nothing -> return True + Just _ -> doIt + Nothing -> doIt + doIt :: IO Bool + doIt = do + reflectIDE (do + errs <- readIDE errors + when (length (filter isError errs) == 0) $ do + ideMessage Normal "Update meta info for active package" + setInfo buildActiveInfo) ideR session + return False + in do + timeoutAddFull myRebuild priorityDefaultIdle 500 + return () + +rebuildActiveInfo = setInfo buildActiveInfo + +-- +-- | 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 + case activePack of + Nothing -> return Nothing + Just idePackage -> do + collectorPath <- lift $ getCollectorPath cProjectVersion + packageDescr <- liftIO $ loadInfosForPackage collectorPath True + (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 + case activePack of + Nothing -> return Nothing + Just idePackage -> do + libDir <- liftIO $ getSysLibDir + liftIO $ runGhc (Just libDir) + $ collectUninstalled False cProjectVersion (cabalFile idePackage) + -- ideMessage Normal "uninstalled collected" + collectorPath <- lift $ getCollectorPath cProjectVersion + packageDescr <- liftIO $ loadInfosForPackage collectorPath True + (packageId idePackage) + case packageDescr of + Nothing -> return Nothing + Just pd -> do + let scope = buildScope pd (Map.empty,Map.empty) + return (Just scope) + +rebuildLibInfo :: IDEAction +rebuildLibInfo = do + updateAccessibleInfo + rebuildActiveInfo + +-- +-- | Updates the world info (it is the responsibility of the caller to rebuild +-- the current info) +-- +updateAccessibleInfo :: IDEAction +updateAccessibleInfo = do + wi <- readIDE accessibleInfo + let version = cProjectVersion + case wi of + Nothing -> loadAccessibleInfo + Just (psmap,psst) -> do + packageInfos <- lift getInstalledPackageInfos + let packageIds = map 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 <- liftIO $ mapM (\pid -> loadInfosForPackage collectorPath False 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 -> Bool -> PackageIdentifier -> IO (Maybe PackageDescr) +loadInfosForPackage dirPath isWorkingPackage pid = do + let filePath = dirPath fromPackageIdentifier pid ++ (if isWorkingPackage then ".packw" else ".pack") + exists <- doesFileExist filePath + if exists + then catch (do + file <- openBinaryFile filePath ReadMode + bs <- BS.hGetContents file + let (metadataVersion', packageInfo) = decode bs + if metadataVersion /= metadataVersion' + then do + hClose file + throwIDE ("Metadata has a wrong version." + ++ " Consider rebuilding metadata with -r option") + else do + packageInfo `deepSeq` (hClose file) + return (Just packageInfo)) + (\e -> do sysMessage Normal (show e); return Nothing) + else do + sysMessage Normal $"packageInfo not found for " ++ fromPackageIdentifier 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' buildScope symbolTable allDescriptions + where + allDescriptions = concatMap idDescriptionsMD (exposedModulesPD pDescr) + buildScope st idDescr = + let allDescrs = allDescrsFrom idDescr + in foldl' (\ map descr -> Map.insertWith (++) (descrName descr) [descr] map) + st allDescrs + allDescrsFrom descr | isReexported descr = [descr] + | otherwise = + case details descr of + DataDescr constructors fields -> + descr : (map (\(fn,ty) -> Descr{descrName' = fn, typeInfo' = ty, + descrModu' = descrModu descr, mbLocation' = mbLocation descr, + mbComment' = mbComment descr, details' = FieldDescr {typeDescrF = descr}}) + fields + ++ (map (\(fn,ty) -> Descr{descrName' = fn, typeInfo' = ty, + descrModu' = descrModu descr, mbLocation' = mbLocation descr, + mbComment' = mbComment descr, details' = ConstructorDescr {typeDescrC = descr}}) + constructors)) + ClassDescr _ methods -> + descr : (map (\(fn,ty) -> Descr{descrName' = fn, typeInfo' = ty, + descrModu' = descrModu descr, mbLocation' = mbLocation descr, + mbComment' = mbComment descr, details' = MethodDescr {classDescrM = descr}}) + methods) + NewtypeDescr constr mbField -> + descr : Descr{descrName' = fst constr, typeInfo' = snd constr, + descrModu' = descrModu descr, mbLocation' = mbLocation descr, + mbComment' = mbComment descr, details' = ConstructorDescr {typeDescrC = descr}} + : case mbField of + Just fld -> + [Descr{descrName' = fst fld, typeInfo' = snd fld, + descrModu' = descrModu descr, mbLocation' = mbLocation descr, + mbComment' = mbComment descr, details' = FieldDescr {typeDescrF = descr}}] + Nothing -> [] + InstanceDescr _ -> [] + _ -> [descr] + + + +-- --------------------------------------------------------------------- +-- 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) + +instance DeepSeq ModuleDescr where + deepSeq pd = deepSeq (moduleIdMD pd) + $ deepSeq (mbSourcePathMD pd) + $ deepSeq (exportedNamesMD pd) + $ deepSeq (usagesMD pd) + +instance DeepSeq Descr where + deepSeq (Descr descrName' typeInfo' descrModu' + mbLocation' mbComment' details') = deepSeq descrName' + $ deepSeq typeInfo' + $ deepSeq descrModu' + $ deepSeq mbLocation' + $ deepSeq mbComment' + $ deepSeq details' + deepSeq (Reexported reexpModu' impDescr') = deepSeq reexpModu' + $ deepSeq impDescr' + +instance DeepSeq SpDescr where + deepSeq (FieldDescr typeDescrF') = deepSeq typeDescrF' + deepSeq (ConstructorDescr typeDescrC') = deepSeq typeDescrC' + deepSeq (DataDescr constructors' fields') = deepSeq constructors' + $ deepSeq fields' + deepSeq (NewtypeDescr constructor' mbField') = deepSeq constructor' + $ deepSeq mbField' + deepSeq (ClassDescr super' methods') = deepSeq super' + $ deepSeq methods' + deepSeq (MethodDescr classDescrM') = deepSeq classDescrM' + deepSeq (InstanceDescr binds') = deepSeq binds' + deepSeq a = seq a + + +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 DescrType 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) + +instance DeepSeq ModuleName where + deepSeq = deepSeq . components + +instance DeepSeq PackageName where + deepSeq (PackageName s) = deepSeq s + diff --git a/src/IDE/Metainfo/SourceCollector.hs b/src/IDE/Metainfo/SourceCollector.hs --- a/src/IDE/Metainfo/SourceCollector.hs +++ b/src/IDE/Metainfo/SourceCollector.hs @@ -1,10 +1,11 @@ +{-# OPTIONS_GHC -XScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Metainfo.SourceCollector -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL -- --- Maintainer : Juergen Nicklisch-Franken +-- Maintainer : Juergen Nicklisch-Franken -- Stability : experimental -- Portability : portable -- @@ -13,8 +14,7 @@ ------------------------------------------------------------------------------- module IDE.Metainfo.SourceCollector ( - collectAllSources -, collectSources + collectSources , buildSourceForPackageDB , sourceForPackage , parseSourceForPackageDB @@ -33,17 +33,13 @@ 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.List (foldl',nub,delete,sort) import Data.Maybe(catMaybes) import qualified Control.Exception as C import qualified Data.ByteString.Char8 as BS +import Distribution.PackageDescription.Parse (readPackageDescription) +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Control.Exception (SomeException) import GHC hiding (idType) @@ -52,18 +48,14 @@ 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 +import IDE.FileUtils +import IDE.Pane.Preferences +import Digraph (flattenSCCs) +import HscTypes (msHsFilePath) -- --------------------------------------------------------------------- -- Function to map packages to file paths @@ -73,8 +65,7 @@ getSourcesMap = do mbSources <- parseSourceForPackageDB case mbSources of - Just map -> do - return map + Just map -> return map Nothing -> do buildSourceForPackageDB mbSources <- parseSourceForPackageDB @@ -98,8 +89,13 @@ 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)) + mbPackages <- mapM (\fp -> parseCabal fp) fCabalFiles + let pdToFiles = Map.fromListWith (++) + $ map (\(Just p,o ) -> (p,o)) + $ filter (\(mb, _) -> case mb of + Nothing -> False + _ -> True ) + $ zip mbPackages (map (\a -> [a]) fCabalFiles) filePath <- getConfigFilePathForSave "source_packages.txt" writeFile filePath (PP.render (showSourceForPackageDB pdToFiles)) @@ -107,7 +103,7 @@ 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) + 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 @@ -182,17 +178,17 @@ whiteSpace = P.whiteSpace lexer symbol = P.symbol lexer -parseCabal :: FilePath -> IO String +parseCabal :: FilePath -> IO (Maybe 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 + sysMessage Normal $"Error reading cabal file " ++ show fn ++ " " ++ show pe + return Nothing Right r -> do sysMessage Normal r - return r + return (Just r) cabalMinimalParser :: CharParser () String cabalMinimalParser = do @@ -202,11 +198,11 @@ Left v -> do case r2 of Right n -> return (n ++ "-" ++ v) - Left _ -> throwIDE "Illegal cabal" + Left _ -> unexpected "Illegal cabal" Right n -> do case r2 of Left v -> return (n ++ "-" ++ v) - Right _ -> throwIDE "Illegal cabal" + Right _ -> unexpected "Illegal cabal" cabalMinimalP :: CharParser () (Either String String) cabalMinimalP = @@ -234,110 +230,110 @@ -- -- --------------------------------------------------------------------- --- | 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] +collectSources :: Map PackageIdentifier [FilePath] -> PackageDescr - -> IO (PackageDescr,Int) -collectSources session sourceMap pdescr = do - putStrLn $ "Now collecting sources for " ++ show (packagePD pdescr) + -> Ghc (PackageDescr,Int) +collectSources sourceMap pdescr = do + sysMessage Normal $ "Now collecting sources for " ++ display (packagePD pdescr) case sourceForPackage (packagePD pdescr) sourceMap of Nothing -> do - sysMessage Normal $ "No source for package " ++ showPackageId (packagePD pdescr) + sysMessage Normal $ "No source for package " ++ display (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 + Just cabalPath -> gcatch (do + setTargets [] + load LoadAllTargets + basePath <- liftIO $ canonicalizePath (takeDirectory cabalPath) + pkgDescr <- gcatch (liftIO $ (liftM flattenPackageDescription + (readPackageDescription silent cabalPath))) + (\(e :: SomeException) -> return emptyPackageDescription) + dflags <- getSessionDynFlags + let flags = [noLoc "-fglasgow-exts", noLoc "-cpp", noLoc ("-I" ++ basePath "include"), + noLoc ("-I" ++ basePath)] + (dflags2,_,_) <- parseDynamicFlags dflags flags + let buildPaths = nub $ ("dist" "build" "autogen") : (".") : + (concatMap hsSourceDirs $ allBuildInfo pkgDescr) + let dflags3 = dopt_set dflags2 Opt_Haddock + let dflags4 = dflags3 { + topDir = basePath, + importPaths = buildPaths, +-- hscTarget = HscAsm, + ghcMode = CompManager, + ghcLink = NoLink} + setSessionDynFlags dflags4 + trace ("basePath = " ++ basePath) (return ()) + trace ("buildPaths = " ++ show buildPaths) (return ()) - setSessionDynFlags session dflags2 + defaultCleanupHandler dflags (do + let exposedMods = map (display . modu . moduleIdMD) $ exposedModulesPD pdescr + sourceFiles <- liftIO $ mapM (findSourceFile + (map (\p -> basePath p) buildPaths) + ["hs","lhs","chs","hs.pp","lhs.pp","chs.pp"]) + $ map (modu . moduleIdMD) (exposedModulesPD pdescr) - 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)) + liftIO $ mapM_ (\(mbSf, mn) -> + case mbSf of + Nothing -> putStrLn $ "Cant find source file for " ++ mn + Just _ -> return ()) $ zip sourceFiles exposedMods + (newModDescrs,failureCount) <- collectSourcesForPackage pdescr (catMaybes sourceFiles) + let nPackDescr = pdescr{mbSourcePathPD = Just cabalPath, + exposedModulesPD = newModDescrs} + return (nPackDescr,failureCount))) + (\(e :: SomeException) -> do + sysMessage Normal $ "source collector throwIDE1 " ++ show e ++ " in " ++ + display (packagePD pdescr) ++ " missed " + ++ show (length $ exposedModulesPD 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) + +-------------------------- + +collectSourcesForPackage :: PackageDescr -> [String] -> Ghc ([ModuleDescr],Int) +collectSourcesForPackage pkgDescr modules = do + targets <- mapM (\f -> guessTarget f Nothing) modules + setTargets targets + modgraph <- depanal [] False + let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing +-- let interestingMods = filter (\m -> elem (moduleNameString (ms_mod_name m)) modules) orderedMods + let orderedTupels = catMaybes (map (\om -> case filter (\m -> ((moduleNameString . moduleName . ms_mod) om) == + (display . modu . moduleIdMD) m) + (exposedModulesPD pkgDescr) of + [] -> trace ("Cant find module source " ++ (moduleNameString . moduleName . ms_mod) om) $ Nothing + (x:_) -> (Just (x,om))) orderedMods) +-- trace ("ordered tupels " ++ (show . length) orderedTupels) $ return () + foldM collectSourcesForModule ([],0) orderedTupels + +collectSourcesForModule :: ([ModuleDescr],Int) -> (ModuleDescr, ModSummary) -> Ghc ([ModuleDescr],Int) +collectSourcesForModule (moduleDescrs,failureCount) (modD,modsum) = gcatch (do + let filename = msHsFilePath modsum + let dynflags = ms_hspp_opts modsum + parsedMod <- parseModule modsum + let decls = (hsmodDecls . unLoc . parsedSource) $ parsedMod + let map' = convertToMap (idDescriptionsMD modD) + let commentedDecls = addComments (filterSignatures decls) + let (descrs,restMap) = foldl' collectParseInfoForDecl ([],map') commentedDecls + let newMod = modD{ + idDescriptionsMD = reverse descrs ++ concat (Map.elems restMap), + mbSourcePathMD = Just filename} + return(newMod : moduleDescrs, failureCount)) + (\(e :: SomeException) -> do + sysMessage Normal $ "source collector throwIDE2 " ++ show e ++ " in " ++ + msHsFilePath modsum + return (modD : 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 + convertToMap :: [Descr] -> Map Symbol [Descr] + convertToMap list = + foldl' (\ st idDescr -> Map.insertWith (++) (descrName idDescr) [idDescr] st) + Map.empty list + convertFromMap :: Map Symbol [Descr] -> [Descr] + convertFromMap = concat . Map.elems + filterSignatures :: [LHsDecl RdrName] -> [LHsDecl RdrName] filterSignatures declList = filter filterSignature declList where @@ -345,7 +341,7 @@ filterSignature _ = True addComments :: [LHsDecl RdrName] -> [(Maybe (LHsDecl RdrName), Maybe String)] -addComments declList = reverse $ snd $ foldl addComment (Nothing,[]) declList +addComments = reverse . snd . foldl' addComment (Nothing,[]) where addComment :: (Maybe String,[(Maybe (LHsDecl RdrName),Maybe String)]) -> LHsDecl RdrName @@ -360,17 +356,15 @@ (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) + addComment (Nothing,resultList) decl = (Nothing,(Just decl,Nothing):resultList) + addComment (Just comment,resultList) decl = (Nothing,(Just decl,Just comment):resultList) -collectParseInfoForDecl :: ([IdentifierDescr],SymbolTable) +collectParseInfoForDecl :: ([Descr],SymbolTable) -> (Maybe (LHsDecl RdrName),Maybe String) - -> ([IdentifierDescr],SymbolTable) + -> ([Descr],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] [] + = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Variable] [] 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') @@ -401,18 +395,18 @@ 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) + = {--trace (declTypeToString (unLoc decl) ++ "--" ++ (showSDocUnqual $ppr decl))--} (l,st) collectParseInfoForDecl (l,st) (Nothing, mbComment') = - trace ("Found comment " ++ show mbComment') (l,st) + {--trace ("Found comment " ++ show mbComment')--} (l,st) -addLocationAndComment :: ([IdentifierDescr],SymbolTable) +addLocationAndComment :: ([Descr],SymbolTable) -> RdrName -> SrcSpan -> Maybe String - -> [IdType] + -> [DescrType] -> [String] - -> ([IdentifierDescr],SymbolTable) + -> ([Descr],SymbolTable) addLocationAndComment (l,st) lid srcSpan mbComment' types insts = let occ = rdrNameOcc lid name = unpackFS (occNameFS occ) @@ -427,21 +421,21 @@ 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 + Just identDescr |not (isReexported identDescr) -> (identDescr{ + mbLocation' = Just (srcSpanToLocation srcSpan), + mbComment' = case mbComment' of Nothing -> Nothing Just s -> Just (BS.pack s)} : l, nst) + otherwise -> (l,st) where - matches :: IdentifierDescr -> [IdType] -> [String] -> Bool + matches :: Descr -> [DescrType] -> [String] -> Bool matches idDescr idTypes inst = - case idType idDescr of + case descrType (details idDescr) of Instance -> --trace ("instances " ++ show (sort (binds idDescr)) ++ " -- ?= -- " ++ show (sort inst)) $ - elem Instance idTypes && sort (binds idDescr) == sort inst + elem Instance idTypes && sort (binds (details idDescr)) == sort inst other -> elem other idTypes declTypeToString :: Show alpha => HsDecl alpha -> String @@ -452,12 +446,11 @@ declTypeToString (SigD _) = "SigD" declTypeToString (DefD _) = "DefD" declTypeToString (ForD _) = "ForD" -declTypeToString (DeprecD _)= "DeprecD" +declTypeToString (WarningD _)= "WarnD" declTypeToString (RuleD _) = "RuleD" declTypeToString (SpliceD _) = "SpliceD" declTypeToString (DocD v) = "DocD " ++ show v - srcSpanToLocation :: SrcSpan -> Location srcSpanToLocation span | not (isGoodSrcSpan span) = throwIDE "srcSpanToLocation: unhelpful span" @@ -493,89 +486,4 @@ show (DocCommentPrev doc) = "DocCommentPrev " ++ show doc show (DocCommentNamed str doc) = "DocCommentNamed" ++ " " ++ str ++ " " ++ show doc show (DocGroup i doc) = "DocGroup" ++ " " ++ show i ++ " " ++ show doc - ---instance Show alpha => Show (HsDoc alpha) where --- show d = printHsDoc d - - - --------------------------------------------------------------------- --- | Simple preprocessing - -preprocess :: FilePath -> GenericPackageDescription -> LocalBuildInfo -> IO String -preprocess fp pkgDescr localBuildInfo = - let aBuildInfo = head (allBuildInfo (flattenPackageDescription pkgDescr)) - needCpp = elem "-cpp" (hcOptions GHC (options aBuildInfo)) - in C.catch (do - str' <- if True - then do - tempFileName <- getConfigFilePathForSave "Temp.hspp" - isItTheir <- doesFileExist tempFileName - when isItTheir $ - removeFile tempFileName --- (_, conf') <- requireProgram normal ghcProgram --- (orLaterVersion (Version [6,2] [])) --- defaultProgramConfiguration - --- localBuildInfo' <- localBuildInfo pkgDescr conf' - - runSimplePreProcessor (ppCpp aBuildInfo localBuildInfo) - fp tempFileName normal - isItTheir <- doesFileExist tempFileName - if isItTheir - then do - str <- readFile tempFileName - return str - else do - sysMessage Normal $ "Failed to preprocess " ++ fp - str <- readFile fp - return str - else do - str <- readFile fp - return str - let str2 = if takeExtension fp == ".lhs" - then unlit fp str' - else str' - return str2) - (\e -> do sysMessage Normal $ "preprocess throwIDE " ++ show e ++ " in " ++ fp - str <- readFile fp - return str) - - --------------------------------------------------------------------- --- | Parser function copied here, because it is not exported - -myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer - -> IO (Either ErrMsg (Located (HsModule RdrName))) -myParseModule dflags src_filename maybe_src_buf - = -------------------------- Parser ---------------- - showPass dflags "Parser" >> - {-# SCC "Parser" #-} do - - -- sometimes we already have the buffer in memory, perhaps - -- because we needed to parse the imports out of it, or get the - -- module name. - buf <- case maybe_src_buf of - Just b -> return b - Nothing -> hGetStringBuffer src_filename - - let loc = mkSrcLoc (mkFastString src_filename) 1 0 - - case unP parseModule (mkPState buf loc dflags) of { - - PFailed span err -> return (Left (mkPlainErrMsg span err)); - - POk pst rdr_module -> do { - - let {ms = getMessages pst}; - printErrorsAndWarnings dflags ms; - -- when (errorsFound dflags ms) $ exitWith (ExitFailure 1); - - dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; - - dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" - (ppSourceStats False rdr_module) ; - - return (Right rdr_module) - -- ToDo: free the string buffer later. - }} - diff --git a/src/IDE/ModulesPane.hs b/src/IDE/ModulesPane.hs deleted file mode 100644 --- a/src/IDE/ModulesPane.hs +++ /dev/null @@ -1,792 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- --- Module : IDE.ModulesPane --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | The pane of ide where modules are presented in tree form with their --- packages and exports --- -------------------------------------------------------------------------------- - -module IDE.ModulesPane ( - showModules -, selectIdentifier -, reloadKeepSelection -) where - -import Graphics.UI.Gtk hiding (get) -import Graphics.UI.Gtk.ModelView as New -import Data.Maybe -import Control.Monad.Reader -import qualified Data.Map as Map -import Data.Tree -import Data.List -import Distribution.Package -import Distribution.Version -import Data.Char (toLower) - - -import IDE.Core.State -import IDE.Framework.ViewFrame -import IDE.InfoPane -import IDE.SourceEditor - -instance IDEObject IDEModules - -instance Pane IDEModules - where - primPaneName _ = "Modules" - getAddedIndex _ = 0 - getTopWidget = castToWidget . outer - paneId b = "*Modules" - makeActive p = activatePane p (BufConnections[][] []) - close pane = do - (panePath,_) <- guiPropertiesFromName (paneName pane) - nb <- getNotebook panePath - mbI <- lift $notebookPageNum nb (getTopWidget pane) - case mbI of - Nothing -> throwIDE "Pane>IDEModules: notebook page not found: unexpected" - Just i -> do - deactivatePaneIfActive pane - lift $notebookRemovePage nb i - removePaneAdmin pane - -instance RecoverablePane IDEModules ModulesState where - saveState p = do - (IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) <- getModules - sc <- getScope - mbModules <- getPane ModulesCasting - case mbModules of - Nothing -> return Nothing - Just p -> lift $ do - i <- panedGetPosition (paned p) - mbTreeSelection <- getSelectionTree treeView treeStore - mbFacetSelection <- getSelectionFacet facetView facetStore - let mbs = (case mbTreeSelection of - Nothing -> Nothing - Just (_,[]) -> Nothing - Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md), - case mbFacetSelection of - Nothing -> Nothing - Just fw -> Just (symbolFromFacetWrapper fw)) - return (Just (StateC (ModulesState i sc mbs))) - recoverState pp (ModulesState i sc@(scope,useBlacklist) se) = do - nb <- getNotebook pp - initModules pp nb - mod@(IDEModules _ _ treeView treeStore facetView facetStore lb pb wb blb) - <- getModules - case scope of - Local -> lift $ toggleButtonSetActive lb True - Package -> lift $ toggleButtonSetActive pb True - World -> lift $ toggleButtonSetActive wb True - lift $ toggleButtonSetActive blb useBlacklist - lift $ panedSetPosition (paned mod) i - fillModulesList sc - selectNames se - -selectIdentifier :: IdentifierDescr -> IDEAction -selectIdentifier idDescr = selectIdentifier' (modu $ moduleIdID idDescr) (identifierID idDescr) - - -selectIdentifier' :: ModuleIdentifier -> Symbol -> IDEAction -selectIdentifier' moduleName symbol = - let nameArray = breakAtDots [] moduleName - in do - mods@(IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) <- getModules - tree <- lift $ New.treeStoreGetTree treeStore [] - case treePathFromNameArray tree nameArray [] of - Just treePath -> lift $ do - New.treeViewExpandToPath treeView treePath - sel <- New.treeViewGetSelection treeView - New.treeSelectionSelectPath sel treePath - col <- New.treeViewGetColumn treeView 0 - New.treeViewScrollToCell treeView treePath (fromJust col) (Just (0.3,0.3)) - facetTree <- New.treeStoreGetTree facetStore [] - selF <- New.treeViewGetSelection facetView - case findPathFor symbol facetTree of - Nothing -> sysMessage Normal "no path found" - Just path -> do - New.treeSelectionSelectPath selF path - col <- New.treeViewGetColumn facetView 0 - New.treeViewScrollToCell facetView path (fromJust col) (Just (0.3,0.3)) - bringPaneToFront mods - Nothing -> return () - -findPathFor :: Symbol -> Tree FacetWrapper -> Maybe TreePath -findPathFor symbol (Node _ forest) = - foldr ( \i mbTreePath -> findPathFor' [i] (forest !! i) mbTreePath) - Nothing [0 .. ((length forest) - 1)] - where - findPathFor' :: TreePath -> Tree FacetWrapper -> Maybe TreePath -> Maybe TreePath - findPathFor' _ node (Just p) = Just p - findPathFor' path (Node wrap sub) Nothing = - if identifierID (facetIdDescr wrap) == symbol - then Just (reverse path) - else - foldr ( \i mbTreePath -> findPathFor' (i:path) (sub !! i) mbTreePath) - Nothing [0 .. ((length sub) - 1)] - - - -treePathFromNameArray :: ModTree -> [String] -> [Int] -> Maybe [Int] -treePathFromNameArray tree [] accu = Just (reverse accu) -treePathFromNameArray tree (h:t) accu = - let names = map (\t -> fst $ rootLabel t) (subForest tree) - mbIdx = elemIndex h names - in case mbIdx of - Nothing -> Nothing - Just i -> treePathFromNameArray (subForest tree !! i) t (i:accu) - -showModules :: IDEAction -showModules = do - sc <- getScope - fillModulesList sc - m <- getModules - lift $ bringPaneToFront m - -getModules :: IDEM IDEModules -getModules = do - mbMod <- getPane ModulesCasting - case mbMod of - Nothing -> do - prefs <- readIDE prefs - layout <- readIDE layout - let pp = getStandardPanePath (modulesPanePath prefs) layout - nb <- getNotebook pp - initModules pp nb - mbMod <- getPane ModulesCasting - case mbMod of - Nothing -> throwIDE "Can't init modules" - Just m -> return m - Just m -> return m - -initModules :: PanePath -> Notebook -> IDEAction -initModules panePath nb = do - ideR <- ask - panes <- readIDE panes - paneMap <- readIDE paneMap - prefs <- readIDE prefs - currentInfo <- readIDE currentInfo - (buf,cids) <- lift $ do - --- Modules List - - let forest = case currentInfo of - Nothing -> [] - Just pair -> subForest (buildModulesTree pair) - treeStore <- New.treeStoreNew forest - treeView <- New.treeViewNew - New.treeViewSetModel treeView treeStore - New.treeViewSetEnableSearch treeView True - New.treeViewSetSearchColumn treeView 0 - New.treeViewSetSearchEqualFunc treeView (treeViewSearch treeView treeStore) - - --New.treeViewSetRulesHint treeView True - - renderer0 <- New.cellRendererPixbufNew - set renderer0 [ cellPixbufStockId := "ide_no_source" ] - - renderer <- New.cellRendererTextNew - col <- New.treeViewColumnNew - New.treeViewColumnSetTitle col "Modules" - New.treeViewColumnSetSizing col TreeViewColumnAutosize - New.treeViewColumnSetReorderable col True - New.treeViewAppendColumn treeView col - New.cellLayoutPackStart col renderer0 False - New.cellLayoutPackStart col renderer True - New.cellLayoutSetAttributes col renderer treeStore - $ \row -> [ New.cellText := fst row] - New.cellLayoutSetAttributes col renderer0 treeStore - $ \row -> [ - cellPixbufStockId := - if null (snd row) - then "" - else if isJust (mbSourcePathMD (fst (head (snd row)))) - then "ide_source" - else "ide_no_source"] - - renderer2 <- New.cellRendererTextNew - col2 <- New.treeViewColumnNew - New.treeViewColumnSetTitle col2 "Packages" - New.treeViewColumnSetSizing col2 TreeViewColumnAutosize - New.treeViewColumnSetReorderable col2 True - New.treeViewAppendColumn treeView col2 - New.cellLayoutPackStart col2 renderer2 True - New.cellLayoutSetAttributes col2 renderer2 treeStore - $ \row -> [ New.cellText := - concat - $ intersperse ", " - $ map (showPackageId . packagePD . snd) (snd row)] - --- Facet view - - facetView <- New.treeViewNew - facetStore <- New.treeStoreNew [] - New.treeViewSetModel facetView facetStore - New.treeViewSetEnableSearch facetView True --- New.treeViewSetSearchColumn facetView 0 --- New.treeViewSetSearchEqualFunc facetView --- (\ _ string iter -> do --- [ind] <- New.treeModelGetPath facetStore iter --- val <- New.listStoreGetValue facetStore ind --- return (isInfixOf (map toLower string) (map toLower (fst val)))) - - renderer30 <- New.cellRendererPixbufNew - renderer31 <- New.cellRendererPixbufNew - renderer3 <- New.cellRendererTextNew - col <- New.treeViewColumnNew - New.treeViewColumnSetTitle col "Interface" - --New.treeViewColumnSetSizing col TreeViewColumnAutosize - New.treeViewAppendColumn facetView col - New.cellLayoutPackStart col renderer30 False - New.cellLayoutPackStart col renderer31 False - New.cellLayoutPackStart col renderer3 True - New.cellLayoutSetAttributes col renderer3 facetStore - $ \row -> [ New.cellText := facetTreeText row] - New.cellLayoutSetAttributes col renderer30 facetStore - $ \row -> [ - cellPixbufStockId := stockIdFromType (facetIdType row)] - New.cellLayoutSetAttributes col renderer31 facetStore - $ \row -> [ - cellPixbufStockId := if isJust (mbLocation(facetIdDescr row)) - then "ide_source" - else ""] - New.treeViewSetHeadersVisible treeView True - - pane' <- hPanedNew - sw <- scrolledWindowNew Nothing Nothing - containerAdd sw treeView - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - sw2 <- scrolledWindowNew Nothing Nothing - containerAdd sw2 facetView - scrolledWindowSetPolicy sw2 PolicyAutomatic PolicyAutomatic - panedAdd1 pane' sw - panedAdd2 pane' sw2 - (x,y) <- widgetGetSize nb - panedSetPosition pane' (x `quot` 2) - box <- hBoxNew True 2 - rb1 <- radioButtonNewWithLabel "Local" - rb2 <- radioButtonNewWithLabelFromWidget rb1 "Package" - rb3 <- radioButtonNewWithLabelFromWidget rb1 "World" - cb <- checkButtonNewWithLabel "Blacklist" - - boxPackStart box rb1 PackGrow 2 - boxPackStart box rb2 PackGrow 2 - boxPackStart box rb3 PackGrow 2 - boxPackEnd box cb PackNatural 2 - - boxOuter <- vBoxNew False 2 - boxPackStart boxOuter box PackNatural 2 - boxPackStart boxOuter pane' PackGrow 2 - - let modules = IDEModules boxOuter pane' treeView treeStore facetView facetStore - rb1 rb2 rb3 cb - notebookInsertOrdered nb boxOuter (paneName modules) - widgetShowAll boxOuter - cid0 <- treeView `New.onStartInteractiveSearch` - (New.treeViewExpandAll treeView) - cid3 <- treeView `New.onRowActivated` - (\ treePath _ -> do - New.treeViewExpandRow treeView treePath False - return ()) - cid1 <- treeView `afterFocusIn` - (\_ -> do runReaderT (makeActive modules) ideR; return True) - cid2 <- facetView `afterFocusIn` - (\_ -> do runReaderT (makeActive modules) ideR; return True) - treeView `onButtonPress` (treeViewPopup ideR treeStore treeView) - facetView `onButtonPress` (facetViewPopup ideR facetStore facetView) - rb1 `onToggled` (runReaderT scopeSelection ideR) - rb2 `onToggled` (runReaderT scopeSelection ideR) - rb3 `onToggled` (runReaderT scopeSelection ideR) - cb `onToggled` (runReaderT scopeSelection ideR) - sel <- New.treeViewGetSelection treeView - sel `New.onSelectionChanged` (fillFacets treeView treeStore facetStore) - sel2 <- New.treeViewGetSelection facetView - sel2 `New.onSelectionChanged` (fillInfo facetView facetStore ideR) - - return (modules,[cid1,cid2]) - addPaneAdmin buf (BufConnections [] [] []) panePath - lift $widgetGrabFocus (paned buf) - -stockIdFromType :: IdType -> StockId -stockIdFromType Function = "ide_function" -stockIdFromType Newtype = "ide_newtype" -stockIdFromType Type = "ide_type" -stockIdFromType AbstractData = "ide_data" -stockIdFromType OpenData = "ide_data" -stockIdFromType Foreign = "ide_other" -stockIdFromType Data = "ide_data" -stockIdFromType Class = "ide_class" -stockIdFromType Instance = "ide_instance" -stockIdFromType Constructor = "ide_konstructor" -stockIdFromType Field = "ide_slot" -stockIdFromType Method = "ide_method" -stockIdFromType OrphanedInstance = "ide_instance" - -treeViewSearch :: TreeView - -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) - -> Int - -> String - -> TreeIter - -> IO Bool -treeViewSearch treeView treeStore _ string iter = do - path <- New.treeModelGetPath treeStore iter - val <- New.treeStoreGetValue treeStore path - tree <- New.treeStoreGetTree treeStore path - exp <- New.treeViewRowExpanded treeView path - when (not (null (subForest tree)) && not exp) $ - let found = searchInSubnodes tree string - in when found $ do - New.treeViewExpandRow treeView path False - return () - let str2 = case snd val of - [] -> fst val - (m,_):_ -> showPackModule (moduleIdMD m) - return (isInfixOf (map toLower string) (map toLower str2)) - -searchInSubnodes :: ModTree -> String -> Bool -searchInSubnodes tree str = - not $ null - $ filter (\ val -> - let cstr = case snd val of - [] -> fst val - (m,_):_ -> showPackModule (moduleIdMD m) - in isInfixOf (map toLower str) (map toLower cstr)) - $ concatMap flatten (subForest tree) - -fillFacets :: New.TreeView - -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) - -> New.TreeStore FacetWrapper - -> IO () -fillFacets treeView tst treeStore = do - sel <- getSelectionTree treeView tst - case sel of - Just val - -> case snd val of - ((mod,package):_) - -> let forest = buildFacetForrest mod in do - New.treeStoreClear treeStore - mapM_ (\(e,i) -> New.treeStoreInsertTree treeStore [] i e) - $ zip forest [0 .. length forest] - [] -> return () - Nothing - -> New.treeStoreClear treeStore - - -getSelectionTree :: New.TreeView - -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) - -> IO (Maybe (String, [(ModuleDescr,PackageDescr)])) -getSelectionTree treeView treeStore = do - treeSelection <- New.treeViewGetSelection treeView - paths <- New.treeSelectionGetSelectedRows treeSelection - case paths of - [] -> return Nothing - a:r -> do - val <- New.treeStoreGetValue treeStore a - return (Just val) - -getSelectionFacet :: New.TreeView - -> New.TreeStore FacetWrapper - -> IO (Maybe FacetWrapper) -getSelectionFacet treeView treeStore = do - treeSelection <- New.treeViewGetSelection treeView - paths <- New.treeSelectionGetSelectedRows treeSelection - case paths of - a:r -> do - val <- New.treeStoreGetValue treeStore a - return (Just val) - _ -> return Nothing - - -fillInfo :: New.TreeView - -> New.TreeStore FacetWrapper - -> IDERef - -> IO () -fillInfo treeView lst ideR = do - treeSelection <- New.treeViewGetSelection treeView - paths <- New.treeSelectionGetSelectedRows treeSelection - case paths of - [] -> return () - [a] -> do - wrapper <- New.treeStoreGetValue lst a - runReaderT (setInfos [facetIdDescr wrapper]) ideR - return () - _ -> return () - -findDescription :: PackModule -> SymbolTable -> Symbol -> Maybe (Symbol,IdentifierDescr) -findDescription md st s = - case Map.lookup s st of - Nothing -> Nothing - Just l -> case filter (\id -> md == moduleIdID id) l of - [] -> Nothing - l -> Just (s,head l) - -fillModulesList :: (Scope,Bool) -> IDEAction -fillModulesList (scope,useBlacklist) = do - (IDEModules _ _ treeView treeStore _ _ _ _ _ _) <- getModules - prefs <- readIDE prefs - currentInfo' <- readIDE currentInfo - accessibleInfo' <- readIDE accessibleInfo - case currentInfo' of - Nothing -> case (scope,accessibleInfo') of - (World,Just ai@(pm,ps)) -> - let p2 = if useBlacklist - then (Map.filter (filterBlacklist - (packageBlacklist prefs)) pm, ps) - else ai - (Node _ li) = buildModulesTree - ((Map.empty,Map.empty),p2) - in lift $ do - New.treeStoreClear treeStore - mapM_ (\(e,i) -> New.treeStoreInsertTree treeStore [] i e) - $ zip li [0 .. length li] - New.treeViewExpandAll treeView - _ -> lift $ do - New.treeStoreClear treeStore - New.treeStoreInsertTree treeStore [] 0 (Node ("",[]) []) - New.treeViewExpandAll treeView - Just (l,p) -> let (l',p'@(pm,ps)) = case scope of - Local -> (l,(Map.empty,Map.empty)) - Package -> (l,p) - World -> case accessibleInfo' of - Just ai -> (l,ai) - Nothing -> (l,p) - p2 = if useBlacklist - then (Map.filter (filterBlacklist - (packageBlacklist prefs)) pm, ps) - else p' - (Node _ li) = buildModulesTree (l',p2) - in lift $ do - emptyModel <- New.treeStoreNew [] - New.treeViewSetModel treeView emptyModel - New.treeStoreClear treeStore - mapM_ (\(e,i) -> New.treeStoreInsertTree treeStore [] i e) - $ zip li [0 .. length li] - New.treeViewSetModel treeView treeStore - New.treeViewExpandAll treeView - where - filterBlacklist :: [Dependency] -> PackageDescr -> Bool - filterBlacklist dependencies packageDescr = - let packageId = packagePD packageDescr - name = pkgName packageId - version = pkgVersion packageId - in isNothing $ find (\ (Dependency str vr) -> str == name && withinRange version vr) - dependencies - - -type FacetForest = Forest FacetWrapper -type FacetTree = Tree FacetWrapper - - -facetTreeText :: FacetWrapper -> String -facetTreeText (Itself (SimpleDescr id FunctionS _ _ _ _)) = "function " ++ id -facetTreeText (Itself (SimpleDescr id NewtypeS _ _ _ _)) = "newtype " ++ id -facetTreeText (Itself (SimpleDescr id TypeS _ _ _ _)) = "type " ++ id -facetTreeText (Itself (SimpleDescr id _ _ _ _ _)) = id -facetTreeText (Itself (DataDescr id _ _ _ _ _ _)) = "data " ++ id -facetTreeText (Itself (ClassDescr id _ _ _ _ _)) = "class " ++ id -facetTreeText (Itself (InstanceDescr cl _ _ _ _ )) = "instance " ++ cl -facetTreeText (ConstructorW s _) = "constructor " ++ s -facetTreeText (FieldW s _) = "slot " ++ s -facetTreeText (MethodW s _) = "method " ++ s -facetTreeText (OrphanedData (InstanceDescr cl binds _ _ _)) = "instance " ++ cl - ++ " " ++ printBinds binds - where - printBinds [] = "" - printBinds (a:[]) = a - printBinds (a:b) = a ++ " " ++ printBinds b -facetTreeText _ = throwIDE "impossible in facetTreeText" - -facetIdType :: FacetWrapper -> IdType -facetIdType (Itself descr) = idType descr -facetIdType (ConstructorW _ _) = Constructor -facetIdType (FieldW _ _) = Field -facetIdType (MethodW _ _) = Method -facetIdType (OrphanedData _) = OrphanedInstance - -facetIdDescr :: FacetWrapper -> IdentifierDescr -facetIdDescr (Itself descr) = descr -facetIdDescr (ConstructorW _ descr) = descr -facetIdDescr (FieldW _ descr) = descr -facetIdDescr (MethodW _ descr) = descr -facetIdDescr (OrphanedData descr) = descr - -buildFacetForrest :: ModuleDescr -> FacetForest -buildFacetForrest modDescr = - let (instances,other) = partition (\id -> case id of - InstanceDescr _ _ _ _ _ -> True - _ -> False) - $ idDescriptionsMD modDescr - forestWithoutInstances = map buildFacet other - (forest2,orphaned) = foldl addInstances (forestWithoutInstances,[]) - instances - orphanedNodes = map (\ inst -> Node (OrphanedData inst) []) orphaned - in forest2 ++ reverse orphanedNodes - where - buildFacet :: IdentifierDescr -> FacetTree - buildFacet d@(SimpleDescr _ _ _ _ _ _) - = Node (Itself d) [] - buildFacet d@(DataDescr _ _ _ constID fieldsID _ _) - = (Node (Itself d) ((map (\ s -> Node (ConstructorW s d) []) constID) - ++ (map (\ s -> Node (FieldW s d) []) fieldsID))) - buildFacet d@(ClassDescr _ _ _ classOpsID _ _) - = Node (Itself d) (map (\ s -> Node (MethodW s d) []) classOpsID) - buildFacet d@(InstanceDescr _ _ _ _ _) - = throwIDE "Impossible in buildFacet" - - addInstances :: (FacetForest,[IdentifierDescr]) - -> IdentifierDescr - -> (FacetForest,[IdentifierDescr]) - addInstances (forest,orphaned) instDescr = - case foldl (matches instDescr) ([],False) forest of - (f,True) -> (f,orphaned) - (f,False) -> (forest, instDescr:orphaned) - - matches :: IdentifierDescr - -> (FacetForest,Bool) - -> FacetTree - -> (FacetForest,Bool) - matches instDescr (forest,False) (Node (Itself dd@(DataDescr id _ _ _ _ _ _)) sub) - | [id] == binds instDescr - = ((Node (Itself dd) (sub ++ [Node (Itself instDescr) []])):forest,True) - matches instDescr (forest,False) (Node (Itself dd@(SimpleDescr id ty _ _ _ _ )) sub) - | [id] == binds instDescr && ty == NewtypeS - = ((Node (Itself dd) (sub ++ [Node (Itself instDescr) []])):forest,True) - matches _ (forest,b) node = (node:forest,b) - - -type ModTree = Tree (String, [(ModuleDescr,PackageDescr)]) --- --- | Make a Tree with a module desription, package description pairs tree to display. --- Their are nodes with a label but without a module (like e.g. Data). --- -buildModulesTree :: (PackageScope,PackageScope) -> ModTree -buildModulesTree ((localMap,_),(otherMap,_)) = - let flatPairs = concatMap (\p -> map (\m -> (m,p)) (exposedModulesPD p)) - (Map.elems localMap ++ Map.elems otherMap) - emptyTree = (Node ("",[]) []) - resultTree = foldl insertPairsInTree emptyTree flatPairs - in sortTree resultTree - where - insertPairsInTree :: ModTree -> (ModuleDescr,PackageDescr) -> ModTree - insertPairsInTree tree pair = - let nameArray = breakAtDots [] $ modu $ moduleIdMD $ fst pair - pairedWith = map (\n -> (n,pair)) nameArray - in insertNodesInTree pairedWith tree - - insertNodesInTree :: [(String,(ModuleDescr,PackageDescr))] -> ModTree -> ModTree - insertNodesInTree list@[(str2,pair)] (Node (str1,pairs) forest) = - case partition (\ (Node (s,_) _) -> s == str2) forest of - ([],_) -> (Node (str1,pairs) (makeNodes list : forest)) - ([(Node (_,pairsf) l)],rest) - -> (Node (str1,pairs) ((Node (str2,pair : pairsf) l) : rest)) - (_,_) -> throwIDE "insertNodesInTree: impossible1" - insertNodesInTree list@((str2,pair):tl) (Node (str1,pairs) forest) = - case partition (\ (Node (s,_) _) -> s == str2) forest of - ([],_) -> (Node (str1,pairs) (makeNodes list : forest)) - ([found],rest) -> (Node (str1,pairs) (insertNodesInTree tl found : rest)) - (_,_) -> throwIDE "insertNodesInTree: impossible2" - insertNodesInTree [] t = t - - makeNodes :: [(String,(ModuleDescr,PackageDescr))] -> ModTree - makeNodes [(str,pair)] = Node (str,[pair]) [] - makeNodes ((str,_):tl) = Node (str,[]) [makeNodes tl] - makeNodes _ = throwIDE "Impossible in makeNodes" - -breakAtDots :: [String] -> String -> [String] -breakAtDots res [] = reverse res -breakAtDots res toBreak = let (newRes,newToBreak) = span (\c -> c /= '.') toBreak - in if null newToBreak - then reverse (newRes : res) - else breakAtDots (newRes : res) (tail newToBreak) - - -instance Ord a => Ord (Tree a) where - compare (Node l1 _) (Node l2 _) = compare l1 l2 - -sortTree :: Ord a => Tree a -> Tree a -sortTree (Node l forest) = Node l (sort (map sortTree forest)) - -treeViewPopup :: IDERef - -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) - -> New.TreeView - -> Event - -> IO (Bool) -treeViewPopup ideR store treeView (Button _ click _ _ _ _ button _ _) = do - if button == RightButton - then do - theMenu <- menuNew - item1 <- menuItemNewWithLabel "Edit" - item1 `onActivateLeaf` do - sel <- getSelectionTree treeView store - case sel of - Just (_,[(m,_)]) -> case mbSourcePathMD m of - Nothing -> return () - Just fp -> do - runReaderT (selectSourceBuf fp) ideR - return () - otherwise -> return () - item2 <- menuItemNewWithLabel "ExpandAll" - item2 `onActivateLeaf` (New.treeViewExpandAll treeView) - item3 <- menuItemNewWithLabel "CollapseAll" - item3 `onActivateLeaf` (New.treeViewCollapseAll treeView) - mapM_ (menuShellAppend theMenu) [item1,item2,item3] - menuPopup theMenu Nothing - widgetShowAll theMenu - return True - else if button == LeftButton && click == DoubleClick - then do sel <- getSelectionTree treeView store - case sel of - Just (_,[(m,_)]) -> case mbSourcePathMD m of - Nothing -> return () - Just fp -> do - runReaderT (selectSourceBuf fp) ideR - return () - otherwise -> return () - return True - else return False -treeViewPopup _ _ _ _ = throwIDE "treeViewPopup wrong event type" - -facetViewPopup :: IDERef - -> New.TreeStore FacetWrapper - -> New.TreeView - -> Event - -> IO (Bool) -facetViewPopup ideR store facetView (Button _ click _ _ _ _ button _ _) = do - if button == RightButton - then do - theMenu <- menuNew - item1 <- menuItemNewWithLabel "Go to definition" - item1 `onActivateLeaf` do - sel <- getSelectionFacet facetView store - case sel of - Just wrapper -> runReaderT - (goToDefinition (facetIdDescr wrapper)) ideR - otherwise -> sysMessage Normal "no selection" - menuShellAppend theMenu item1 - menuPopup theMenu Nothing - widgetShowAll theMenu - return True - else if button == LeftButton && click == DoubleClick - then do sel <- getSelectionFacet facetView store - case sel of - Just wrapper -> runReaderT (goToDefinition - (facetIdDescr wrapper)) ideR - otherwise -> sysMessage Normal "no selection" - return True - else do - return False - -facetViewPopup _ _ _ _ = throwIDE "facetViewPopup wrong event type" - -getScope :: IDEM (Scope,Bool) -getScope = do - (IDEModules _ _ treeView treeStore facetView facetStore localScopeB - packageScopeB worldScopeB blacklistB) <- getModules - rb1s <- lift $ toggleButtonGetActive localScopeB - rb2s <- lift $ toggleButtonGetActive packageScopeB - rb3s <- lift $ toggleButtonGetActive worldScopeB - cbs <- lift $ toggleButtonGetActive blacklistB - let scope = if rb1s - then Local - else if rb2s - then Package - else if rb3s - then World - else throwIDE - "ModulesPane.scopeSelection: No check button selected" - return (scope,cbs) - -scopeSelection :: IDEAction -scopeSelection = do - mods@(IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) - <- getModules - mbTreeSelection <- lift $ getSelectionTree treeView treeStore - mbFacetSelection <- lift $ getSelectionFacet facetView facetStore - - sc <- getScope - ts <- lift $ New.treeViewGetSelection treeView - lift $ New.treeSelectionUnselectAll ts - fillModulesList sc - let mbs = (case mbTreeSelection of - Nothing -> Nothing - Just (_,[]) -> Nothing - Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md), - case mbFacetSelection of - Nothing -> Nothing - Just fw -> Just (symbolFromFacetWrapper fw)) - selectNames mbs - lift $ bringPaneToFront mods - -selectNames :: (Maybe String, Maybe Symbol) -> IDEAction -selectNames (mbModuleName, mbIdName) = do - (IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) - <- getModules - case mbModuleName of - Nothing -> return () - Just moduleName -> - let nameArray = breakAtDots [] moduleName - in do - tree <- lift $ New.treeStoreGetTree treeStore [] - case treePathFromNameArray tree nameArray [] of - Nothing -> return () - Just treePath -> lift $ do - New.treeViewExpandToPath treeView treePath - sel <- New.treeViewGetSelection treeView - New.treeSelectionSelectPath sel treePath - col <- New.treeViewGetColumn treeView 0 - New.treeViewScrollToCell treeView treePath (fromJust col) (Just (0.3,0.3)) - case mbIdName of - Nothing -> return () - Just symbol -> do - facetTree <- New.treeStoreGetTree facetStore [] - selF <- New.treeViewGetSelection facetView - case findPathFor symbol facetTree of - Nothing -> sysMessage Normal "no path found" - Just path -> do - New.treeSelectionSelectPath selF path - col <- New.treeViewGetColumn facetView 0 - New.treeViewScrollToCell facetView path (fromJust col) - (Just (0.3,0.3)) - - -symbolFromFacetWrapper :: FacetWrapper -> Symbol -symbolFromFacetWrapper (Itself idDescr) = identifierID idDescr -symbolFromFacetWrapper (ConstructorW _ idDescr) = identifierID idDescr -symbolFromFacetWrapper (FieldW _ idDescr) = identifierID idDescr -symbolFromFacetWrapper (MethodW _ idDescr) = identifierID idDescr -symbolFromFacetWrapper (OrphanedData idDescr) = identifierID idDescr - -reloadKeepSelection :: IDEAction -reloadKeepSelection = do - mbMod <- getPane ModulesCasting - case mbMod of - Nothing -> return () - Just mods@(IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) - -> do - mbTreeSelection <- lift $ getSelectionTree treeView treeStore - mbFacetSelection <- lift $ getSelectionFacet facetView facetStore - sc <- getScope - fillModulesList sc - lift $ New.treeStoreClear facetStore - let mbs = (case mbTreeSelection of - Nothing -> Nothing - Just (_,[]) -> Nothing - Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md), - case mbFacetSelection of - Nothing -> Nothing - Just fw -> Just (symbolFromFacetWrapper fw)) - selectNames mbs - - - - - - - diff --git a/src/IDE/Package.hs b/src/IDE/Package.hs --- a/src/IDE/Package.hs +++ b/src/IDE/Package.hs @@ -1,11 +1,11 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} +{-# OPTIONS_GHC -XScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Package -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL -- --- Maintainer : Juergen Nicklisch-Franken +-- Maintainer : Juergen Nicklisch-Franken -- Stability : experimental -- Portability : portable -- @@ -17,6 +17,7 @@ module IDE.Package ( packageOpen +, packageNew , packageConfig , packageBuild , packageDoc @@ -27,7 +28,7 @@ , previousError , activatePackage , deactivatePackage -, packageFlags +, getActivePackage , packageInstall , packageRegister @@ -35,34 +36,46 @@ , packageTest , packageSdist , packageOpenDoc + +, getPackageDescriptionAndPath +, getModuleTemplate +, addModuleToPackageDescr ) where import Graphics.UI.Gtk import Control.Monad.Reader -import Distribution.Package +import Distribution.Package hiding (depends,packageId) import Distribution.PackageDescription +import Distribution.PackageDescription.Parse +import Distribution.PackageDescription.Configuration 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.Pane.Log +import Control.Event import IDE.Core.State -import IDE.PackageEditor -import IDE.SourceEditor -import IDE.PackageFlags -import IDE.Framework.ViewFrame -import IDE.Metainfo.Info +import IDE.Pane.PackageEditor +import IDE.Pane.SourceBuffer +import IDE.Pane.PackageFlags +import IDE.Metainfo.Provider +import Distribution.Text (display) +import IDE.FileUtils (getConfigFilePathForLoad) +import MyMissing (replace) +import Distribution.ModuleName (ModuleName(..)) +import Data.List (foldl') +packageNew :: IDEAction +packageNew = packageNew' (\fp -> activatePackage fp >> return ()) + packageOpen :: IDEAction packageOpen = do active <- readIDE activePack @@ -72,6 +85,7 @@ selectActivePackage return () + getActivePackage :: IDEM (Maybe IDEPackage) getActivePackage = do active <- readIDE activePack @@ -79,127 +93,141 @@ Just p -> return (Just p) Nothing -> selectActivePackage +selectActivePackage :: IDEM (Maybe IDEPackage) +selectActivePackage = do + ideR <- ask + window <- readIDE window + mbFilePath <- liftIO $choosePackageFile window + case mbFilePath of + Nothing -> return Nothing + Just filePath -> do + let ppath = dropFileName filePath + exists <- liftIO $ doesFileExist (ppath "IDE.session") + wantToLoadSession <- + if exists + then liftIO $ do + md <- messageDialogNew Nothing [] MessageQuestion ButtonsYesNo + $ "Load the session settings stored with this project?" + rid <- dialogRun md + widgetDestroy md + case rid of + ResponseYes -> return True + otherwise -> return False + else return False + if wantToLoadSession + then triggerEvent ideR (LoadSession (ppath "IDE.session")) >> getActivePackage + else activatePackage filePath + activatePackage :: FilePath -> IDEM (Maybe IDEPackage) activatePackage filePath = do - session <- readIDE session + ideR <- ask let ppath = dropFileName filePath - lift $setCurrentDirectory ppath - ideR <- ask - mbPackageD <- lift $ catch (do + liftIO $ setCurrentDirectory ppath + mbPackageD <- reifyIDE (\ideR session -> catch (do pd <- readPackageDescription normal filePath return (Just (flattenPackageDescription pd))) - (\e -> do - runReaderT (ideMessage Normal ("Can't activate package " ++(show e))) ideR - return Nothing) + (\(e :: SomeException) -> do + reflectIDE (ideMessage Normal ("Can't activate package " ++(show e))) ideR session + 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") + flagFileExists <- liftIO $ doesFileExist (ppath "IDE.flags") if flagFileExists - then lift $readFlags (ppath "IDE.flags") packp + then liftIO $ readFlags (ppath "IDE.flags") packp else return packp) modifyIDE_ (\ide -> return (ide{activePack = (Just pack)})) ide <- getIDE triggerEvent ideR ActivePack + triggerEvent ideR (Sensitivity [(SensitivityProjectActive,True)]) sb <- getSBActivePackage - lift $statusbarPop sb 1 - lift $statusbarPush sb 1 (showPackageId $packageId pack) + liftIO $ statusbarPop sb 1 + liftIO $ statusbarPush sb 1 (display $ packageId pack) return (Just pack) deactivatePackage :: IDEAction deactivatePackage = do + ideR <- ask + oldActivePack <- readIDE activePack + when (isJust oldActivePack) $ do + triggerEvent ideR (SaveSession + ((dropFileName . cabalFile . fromJust) oldActivePack "IDE.session")) + return () modifyIDE_ (\ide -> return (ide{activePack = Nothing})) - ideR <- ask + ideR <- ask triggerEvent ideR ActivePack - sb <- getSBActivePackage - lift $statusbarPop sb 1 - lift $statusbarPush sb 1 "" + when (isJust oldActivePack) $ do + triggerEvent ideR (Sensitivity [(SensitivityProjectActive,False)]) + return () + sb <- getSBActivePackage + liftIO $ statusbarPop sb 1 + liftIO $ 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 () +packageConfig = catchIDE (do + mbPackage <- getActivePackage + log <- getLog + case mbPackage of + Nothing -> return () + Just package -> do + mbPackageD <- reifyIDE (\ideR session -> 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 :: SomeException) -> do + reflectIDE (ideMessage Normal (show e)) ideR session + return Nothing)) + case mbPackageD of + Just packageD -> do + modifyIDE_ (\ide -> return (ide{activePack = + Just package{depends=buildDepends packageD}})) + ask >>= \ideR -> triggerEvent ideR ActivePack + return () + Nothing -> return ()) + (\(e :: SomeException) -> putStrLn (show e)) 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') +packageBuild = catchIDE (do + mbPackage <- getActivePackage + log <- getLog + ideR <- ask + prefs <- readIDE prefs + case mbPackage of + Nothing -> return () + Just package -> do + sb <- getSBErrors + liftIO $statusbarPop sb 1 + liftIO $statusbarPush sb 1 "Building" + unmarkCurrentError + pid' <- reifyIDE (\ideR session -> do + (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","build"] + ++ buildFlags package) + oid <- forkIO (readOut log out) + hSetBuffering err NoBuffering + eid <- forkIO (reflectIDE (readErrForBuild log err) ideR session) + return pid) + when (collectAfterBuild prefs) $ mayRebuildInBackground (Just pid')) + (\(e :: SomeException) -> putStrLn (show e)) 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 () +packageDoc = catchIDE (do + mbPackage <- getActivePackage + log <- getLog + case mbPackage of + Nothing -> return () + Just package -> liftIO $do + (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","haddock"] + ++ (haddockFlags package)) + oid <- forkIO (readOut log out) + eid <- forkIO (readErr log err) + return ()) + (\(e :: SomeException) -> putStrLn (show e)) packageClean :: IDEAction packageClean = do @@ -207,131 +235,145 @@ log <- getLog case mbPackage of Nothing -> return () - Just package -> lift $do - (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","clean"] - ++ (haddockFlags package)) + Just package -> liftIO $do + (inp,out,err,pid) <- runExternal "runhaskell" ["Setup","clean"] 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 () +packageCopy = catchIDE (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 -> liftIO $ do + (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","copy"] + ++ ["--destdir=" ++ fp]) + oid <- forkIO (readOut log out) + eid <- forkIO (readErr log err) + return ()) + (\(e :: SomeException) -> putStrLn (show e)) 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 () +packageRun = catchIDE (do + mbPackage <- getActivePackage + log <- getLog + case mbPackage of + Nothing -> return () + Just package -> liftIO $do + pd <- readPackageDescription normal (cabalFile package) >>= return . flattenPackageDescription + case executables pd of + [(Executable name _ _)] -> do + let path = "dist/build" name 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 ()) + (\(e :: SomeException) -> putStrLn (show e)) 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 () +packageInstall = catchIDE (do + mbPackage <- getActivePackage + log <- getLog + case mbPackage of + Nothing -> return () + Just package -> liftIO $ do + (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","install"] + ++ (installFlags package)) + oid <- forkIO (readOut log out) + eid <- forkIO (readErr log err) + return ()) + (\(e :: SomeException) -> putStrLn (show e)) 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 () +packageRegister = catchIDE (do + mbPackage <- getActivePackage + log <- getLog + case mbPackage of + Nothing -> return () + Just package -> liftIO $do + (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","register"] + ++ (registerFlags package)) + oid <- forkIO (readOut log out) + eid <- forkIO (readErr log err) + return ()) + (\(e :: SomeException) -> putStrLn (show e)) packageUnregister :: IDEAction -packageUnregister = do +packageUnregister = catchIDE (do mbPackage <- getActivePackage log <- getLog case mbPackage of Nothing -> return () - Just package -> lift $do + Just package -> liftIO $do (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","unregister"] ++ (unregisterFlags package)) oid <- forkIO (readOut log out) eid <- forkIO (readErr log err) - return () + return ()) + (\(e :: SomeException) -> putStrLn (show e)) 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 () +packageTest = catchIDE (do + mbPackage <- getActivePackage + log <- getLog + case mbPackage of + Nothing -> return () + Just package -> liftIO $do + (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","test"]) + oid <- forkIO (readOut log out) + eid <- forkIO (readErr log err) + return ()) + (\(e :: SomeException) -> putStrLn (show e)) 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 () +packageSdist = catchIDE (do + mbPackage <- getActivePackage + log <- getLog + case mbPackage of + Nothing -> return () + Just package -> liftIO $do + (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","sdist"] + ++ (sdistFlags package)) + oid <- forkIO (readOut log out) + eid <- forkIO (readErr log err) + return ()) + (\(e :: SomeException) -> putStrLn (show e)) + 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 () +packageOpenDoc = catchIDE (do + mbPackage <- getActivePackage + prefs <- readIDE prefs + log <- getLog + case mbPackage of + Nothing -> return () + Just package -> + let path = dropFileName (cabalFile package) + "dist/doc/html" + display (pkgName (packageId package)) + display (pkgName (packageId package)) + "index.html" + in liftIO $do + (inp,out,err,pid) <- runExternal (browser prefs) [path] + oid <- forkIO (readOut log out) + eid <- forkIO (readErr log err) + return ()) + (\(e :: SomeException) -> putStrLn (show e)) + chooseDir :: String -> IDEM (Maybe FilePath) chooseDir str = do win <- readIDE window - lift $do + liftIO $do dialog <- fileChooserDialogNew (Just $ str) (Just win) @@ -355,52 +397,55 @@ return Nothing _ -> return Nothing + -- --------------------------------------------------------------------- -- | Handling of Compiler errors -- readErrForBuild :: IDELog -> Handle -> IDEAction readErrForBuild log hndl = do - errs <- lift $readAndShow False [] + ideRef <- ask + errs <- liftIO $readAndShow False [] modifyIDE_ (\ide -> return (ide{errors = reverse errs, currentErr = Nothing})) + triggerEvent ideRef (Sensitivity [(SensitivityError,not (null errs))]) 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" + liftIO $statusbarPop sb 1 + liftIO $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 + readAndShow :: Bool -> [ErrorSpec] -> IO [ErrorSpec] + readAndShow inError errs = catch (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) + (\ (_ :: SomeException) -> do + hClose hndl + return errs) selectErr :: Int -> IDEAction selectErr index = do @@ -410,12 +455,12 @@ else do let thisErr = errors !! index succ <- selectSourceBuf (filePath thisErr) - if succ + if isJust succ then markErrorInSourceBuf (line thisErr) (column thisErr) (errDescription thisErr) else return () log :: IDELog <- getLog - lift $ markErrorInLog log (logLines thisErr) + liftIO $ markErrorInLog log (logLines thisErr) unmarkCurrentError :: IDEAction unmarkCurrentError = do @@ -424,13 +469,13 @@ when (isJust currentErr') $ do let theError = errors' !! fromJust currentErr' allBufs <- allBuffers - fpc <- lift $ canonicalizePath $ filePath theError + fpc <- liftIO $ canonicalizePath $ filePath theError let theBufs = filter (\ buf -> isJust (fileName buf) && equalFilePath fpc (fromJust (fileName buf))) allBufs mapM_ removeMark theBufs where - removeMark buf = lift $ do + removeMark buf = liftIO $ do gtkbuf <- textViewGetBuffer (sourceView buf) i1 <- textBufferGetStartIter gtkbuf i2 <- textBufferGetEndIter gtkbuf @@ -518,41 +563,66 @@ colon = P.colon lexer integer = P.integer lexer --- Spawning external processes +-- --------------------------------------------------------------------- +-- | * Utility functions/procedures, that have to do with packages +-- -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 +getPackageDescriptionAndPath :: IDEM (Maybe (PackageDescription,FilePath)) +getPackageDescriptionAndPath = do + active <- readIDE activePack + case active of + Nothing -> do + ideMessage Normal "No active packjage" + return Nothing + Just p -> do + ideR <- ask + reifyIDE (\ideR session -> catch (do + pd <- readPackageDescription normal (cabalFile p) + return (Just (flattenPackageDescription pd,cabalFile p))) + (\(e :: SomeException) -> do + reflectIDE (ideMessage Normal ("Can't load package " ++(show e))) ideR session + return Nothing)) -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 +getModuleTemplate :: PackageDescription -> String -> IO String +getModuleTemplate pd modName = do + filePath <- getConfigFilePathForLoad "Module.template" + template <- readFile filePath + return (foldl' (\ a (from, to) -> replace from to a) template + [("@License@", (show . license) pd), ("@Maintainer@", maintainer pd), + ("@Stability@",stability pd), ("@Portability@",""), + ("@Copyright@", copyright pd),("@ModuleName@", modName)]) -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 +addModuleToPackageDescr :: ModuleName -> Bool -> IDEM () +addModuleToPackageDescr moduleName isExposed = do + active <- readIDE activePack + case active of + Nothing -> do + ideMessage Normal "No active packjage" + return () + Just p -> do + ideR <- ask + reifyIDE (\ideR session -> catch (do + gpd <- readPackageDescription normal (cabalFile p) + if hasConfigs gpd + then do + reflectIDE (ideMessage High + "Cabal File with configurations can't be automatically updated") ideR session + else + let pd = flattenPackageDescription gpd + npd = if isExposed && isJust (library pd) + then pd{library = Just ((fromJust (library pd)){exposedModules = + moduleName : exposedModules (fromJust $ library pd)})} + else let npd1 = case library pd of + Nothing -> pd + Just lib -> pd{library = Just (lib{libBuildInfo = + addModToBuildInfo (libBuildInfo lib) moduleName})} + in npd1{executables = map + (\exe -> exe{buildInfo = addModToBuildInfo (buildInfo exe) moduleName}) + (executables npd1)} + in writePackageDescription (cabalFile p) npd) + (\(e :: SomeException) -> do + reflectIDE (ideMessage Normal ("Can't upade package " ++ show e)) ideR session + return ())) + where + addModToBuildInfo :: BuildInfo -> ModuleName -> BuildInfo + addModToBuildInfo bi mn = bi {otherModules = mn : otherModules bi} diff --git a/src/IDE/PackageEditor.hs b/src/IDE/PackageEditor.hs deleted file mode 100644 --- a/src/IDE/PackageEditor.hs +++ /dev/null @@ -1,368 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : IDE.PackageEditor --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | Module for editing of cabal packages --- ------------------------------------------------------------------------------------ - - -module IDE.PackageEditor ( - packageNew -, packageEdit -, choosePackageDir -, choosePackageFile -) where - -import Graphics.UI.Gtk -import Control.Monad.Reader -import Distribution.Compiler -import Distribution.License -import Distribution.Package -import Distribution.PackageDescription -import Distribution.Version -import Distribution.Verbosity -import System.FilePath -import Data.IORef -import Data.List -import Data.Maybe -import System.Directory - -import IDE.Core.State -import IDE.Utils.File -import IDE.SpecialEditors -import IDE.Framework.ViewFrame -import IDE.BuildInfoEditor -import IDE.Framework.MakeEditor -import IDE.Framework.SimpleEditors -import IDE.Framework.CompositeEditors -import IDE.Framework.Parameters - -standardSetup = "#!/usr/bin/runhaskell \n" - ++ "> module Main where\n" - ++ "> import Distribution.Simple\n" - ++ "> main :: IO ()\n" - ++ "> main = defaultMain\n\n" - -choosePackageDir :: Window -> IO (Maybe FilePath) -choosePackageDir window = do - dialog <- fileChooserDialogNew - (Just $ "Select root folder for project") - (Just window) - FileChooserActionSelectFolder - [("gtk-cancel" - ,ResponseCancel) - ,("gtk-open" - ,ResponseAccept)] - widgetShow dialog - response <- dialogRun dialog - case response of - ResponseAccept -> do - fn <- fileChooserGetFilename dialog - widgetDestroy dialog - return fn - ResponseCancel -> do - widgetDestroy dialog - return Nothing - ResponseDeleteEvent -> do - widgetDestroy dialog - return Nothing - _ -> return Nothing - -choosePackageFile :: Window -> IO (Maybe FilePath) -choosePackageFile window = do - dialog <- fileChooserDialogNew - (Just $ "Select file of project") - (Just window) - FileChooserActionOpen - [("gtk-cancel" - ,ResponseCancel) - ,("gtk-open" - ,ResponseAccept)] - widgetShow dialog - response <- dialogRun dialog - case response of - ResponseAccept -> do - fn <- fileChooserGetFilename dialog - widgetDestroy dialog - return fn - ResponseCancel -> do - widgetDestroy dialog - return Nothing - ResponseDeleteEvent -> do - widgetDestroy dialog - return Nothing - _ -> return Nothing - -packageEdit :: IDEAction -packageEdit = do - window <- readIDE window - mbFileName <- lift $choosePackageFile window - case mbFileName of - Nothing -> return () - Just fileName -> do - let dirName = dropFileName fileName - modules <- lift $allModules dirName - package <- lift $readPackageDescription normal fileName - editPackage (flattenPackageDescription package) dirName modules - return () - -packageNew :: IDEAction -packageNew = do - window <- readIDE window - mbDirName <- lift $choosePackageDir window - case mbDirName of - Nothing -> return () - Just dirName -> do - cfn <- lift $cabalFileName dirName - continue <- do - if isJust cfn - then lift $do - md <- messageDialogNew Nothing [] MessageQuestion ButtonsYesNo - $ "There is already a .cabal file in this directory." - ++ " Continue anyway?" - rid <- dialogRun md - widgetDestroy md - case rid of - ResponseYes -> return True - otherwise -> return False - else return True - when continue $do - modules <- lift $do - b1 <- doesFileExist (dirName "Setup.hs") - b2 <- doesFileExist (dirName "Setup.lhs") - if not (b1 || b2) - then do - sysMessage Normal "Setup.(l)hs does not exist. Writing Standard" - writeFile (dirName "Setup.lhs") standardSetup - else sysMessage Normal "Setup.(l)hs already exist" - allModules dirName - editPackage emptyPackageDescription dirName modules - return () - -type PDescr = [(String,[FieldDescription PackageDescription])] - -packageDD :: FilePath -> [String] -> PDescr -packageDD fp modules = [ - ("Description -1-", [ - mkField - (paraName <<<- ParaName "Package Identifier" $ emptyParams) - package - (\ a b -> b{package = a}) - packageEditor - , mkField - (paraName <<<- ParaName "Cabal version" - $ paraSynopsis <<<- ParaSynopsis - "Does this package depends on a specific version of Cabal?" - $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams) - descCabalVersion - (\ a b -> b{descCabalVersion = a}) - versionRangeEditor - , mkField - (paraName <<<- ParaName "License" $ emptyParams) - license - (\ a b -> b{license = a}) - (staticSelectionEditor [GPL, LGPL, BSD3, BSD4, PublicDomain, AllRightsReserved, OtherLicense]) - , mkField - (paraName <<<- ParaName "License File" $ emptyParams) - licenseFile - (\ a b -> b{licenseFile = a}) - (fileEditor (Just fp) FileChooserActionOpen "Select file") - , mkField - (paraName <<<- ParaName "Copyright" $ emptyParams) - copyright - (\ a b -> b{copyright = a}) - stringEditor - , mkField - (paraName <<<- ParaName "Author" $ emptyParams) - author - (\ a b -> b{author = a}) - stringEditor - , mkField - (paraName <<<- ParaName "Maintainer" $ emptyParams) - maintainer - (\ a b -> b{maintainer = a}) - stringEditor - ]), - ("Description -2-",[ - mkField - (paraName <<<- ParaName "Stability" $ emptyParams) - stability - (\ a b -> b{stability = a}) - stringEditor - , mkField - (paraName <<<- ParaName "Homepage" $ emptyParams) - homepage - (\ a b -> b{homepage = a}) - stringEditor - , mkField - (paraName <<<- ParaName "Package URL" $ emptyParams) - pkgUrl - (\ a b -> b{pkgUrl = a}) - stringEditor - , mkField - (paraName <<<- ParaName "Synopsis" - $ paraSynopsis <<<- ParaSynopsis "A one-line summary of this package" - $ emptyParams) - synopsis - (\ a b -> b{synopsis = a}) - stringEditor - , mkField - (paraName <<<- ParaName "Description" - $ paraSynopsis <<<- ParaSynopsis "A more verbose description of this package" - $ paraShadow <<<- ParaShadow ShadowOut - $ paraMinSize <<<- ParaMinSize (-1,250) - $ emptyParams) - description - (\ a b -> if null a then b{description = " \n\n\n\n\n"} else b{description = a}) - multilineStringEditor - , mkField - (paraName <<<- ParaName "Category" $ emptyParams) - category - (\ a b -> b{category = a}) - stringEditor - ]), - ("Tested With",[ - mkField - (paraName <<<- ParaName "Tested with compiler" - $ paraShadow <<<- ParaShadow ShadowIn - $ paraDirection <<<- ParaDirection Vertical - $ emptyParams) - (\a -> case testedWith a of - [] -> [(GHC,AnyVersion)] - l -> l) - (\ a b -> b{testedWith = a}) - testedWidthEditor - ]), - ("Dependencies",[ - mkField - (paraName <<<- ParaName "Build Dependencies" - $ paraSynopsis <<<- ParaSynopsis "Does this package depends on other packages?" - $ paraDirection <<<- ParaDirection Vertical $ emptyParams) - buildDepends - (\ a b -> b{buildDepends = a}) - dependenciesEditor - ]), - ("Other Files",[ - mkField - (paraName <<<- ParaName "Data Files" - $ paraSynopsis <<<- ParaSynopsis - "A list of files to be installed for run-time use by the package." - $ paraDirection <<<- ParaDirection Vertical $ emptyParams) - dataFiles - (\ a b -> b{dataFiles = a}) - (filesEditor (Just fp) FileChooserActionOpen "Select File") - , mkField - (paraName <<<- ParaName "Extra Source Files" - $ paraSynopsis <<<- ParaSynopsis - "A list of additional files to be included in source distributions." - $ paraDirection <<<- ParaDirection Vertical $ emptyParams) - extraSrcFiles - (\ a b -> b{extraSrcFiles = a}) - (filesEditor (Just fp) FileChooserActionOpen "Select File") - , mkField - (paraName <<<- ParaName "Extra Tmp Files" - $ paraSynopsis <<<- ParaSynopsis - "A list of additional files or directories to be removed by setup clean." - $ paraDirection <<<- ParaDirection Vertical $ emptyParams) - extraTmpFiles - (\ a b -> b{extraTmpFiles = a}) - (filesEditor (Just fp) FileChooserActionOpen "Select File") - ]), - ("Library",[ - mkField - (paraName <<<- ParaName "Library" - $ paraSynopsis <<<- ParaSynopsis - "If the package contains a library, specify the exported modules here" - $ paraDirection <<<- ParaDirection Vertical - $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams) - library - (\ a b -> b{library = a}) - (maybeEditor (libraryEditor BuildEditorFactoryI (Just fp) modules, - paraName <<<- ParaName "Specify exported modules" $ emptyParams) True - "Does this package contain a library?") - ]), - ("Executables",[ - mkField - (paraName <<<- ParaName "Executables" - $ paraSynopsis <<<- ParaSynopsis - "Describe executable programs contained in the package" - $ paraDirection <<<- ParaDirection Vertical $ emptyParams) - executables - (\ a b -> b{executables = a}) - (executablesEditor BuildEditorFactoryI (Just fp) modules) - ])] - - -editPackage :: PackageDescription -> FilePath -> [String] -> IDEAction -editPackage packageD packageDir modules = do - ideR <- ask - lift $editPackage' packageDir packageD (packageDD packageDir modules) ideR --- ideMessage Normal $show res - -editPackage' :: String -> PackageDescription -> PDescr -> IDERef -> IO () -editPackage' packageDir packageD packageDD ideR = - let flatPackageDesc = concatMap snd packageDD - in do - lastAppliedPackageRef <- newIORef packageD - dialog <- windowNew - vb <- vBoxNew False 7 - bb <- hButtonBoxNew - restore <- buttonNewFromStock "Restore" - ok <- buttonNewFromStock "gtk-ok" - cancel <- buttonNewFromStock "gtk-cancel" - boxPackStart bb restore PackNatural 0 - boxPackStart bb ok PackNatural 0 - boxPackStart bb cancel PackNatural 0 - nb <- newNotebook - notebookSetTabPos nb PosTop - res <- mapM - (\ (tabLabel, partPackageDesc) -> do - resList <- mapM (\ (FD _ editorF) -> editorF packageD) partPackageDesc - let (widgetsP, setInjsP, getExtsP, notifiersP) = unzip4 resList - nbbox <- vBoxNew False 0 - mapM_ (\ w -> boxPackStart nbbox w PackNatural 0) widgetsP - sw <- scrolledWindowNew Nothing Nothing - scrolledWindowAddWithViewport sw nbbox - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - notebookAppendPage nb sw tabLabel - return (widgetsP, setInjsP, getExtsP, notifiersP)) - packageDD - let (widgets, setInjs, getExts, notifiers) = - foldl (\ (w,i,e,n) (w2,i2,e2,n2) -> (w ++ w2, i ++ i2, e ++ e2, n ++ n2)) ([],[],[],[]) res - let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of - Just s -> s - Nothing -> "Unnamed") - $concat - $map snd packageDD - ok `onClicked` (do - mbNewPackage <- extractAndValidate packageD getExts fieldNames - case mbNewPackage of - Nothing -> return () - Just newPackage -> do - lastAppliedPackage <- readIORef lastAppliedPackageRef - let PackageIdentifier n v = package newPackage - writePackageDescription (packageDir ++ "/" ++ n ++ ".cabal") newPackage - widgetDestroy dialog - mainQuit) - cancel `onClicked` (do - widgetDestroy dialog - mainQuit) - dialog `onDelete` (\e -> do - widgetDestroy dialog - mainQuit - return True) - boxPackStart vb nb PackGrow 7 - boxPackEnd vb bb PackNatural 7 - containerAdd dialog vb - widgetSetSizeRequest dialog 500 700 - widgetShowAll dialog - mainGUI - return () - diff --git a/src/IDE/PackageFlags.hs b/src/IDE/PackageFlags.hs deleted file mode 100644 --- a/src/IDE/PackageFlags.hs +++ /dev/null @@ -1,209 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : IDE.PackageFlags --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- --- | Module for saving, restoring and editing projectFlags --- ---------------------------------------------------------------------------------- - - -module IDE.PackageFlags ( - readFlags -, writeFlags -, editFlags -) where - -import Graphics.UI.Gtk -import Control.Monad.Reader -import qualified Text.ParserCombinators.Parsec as P -import Data.List -import System.IO -import qualified Text.PrettyPrint.HughesPJ as PP - -import IDE.Core.State -import IDE.Framework.MakeEditor hiding (fieldEditor, parameters) -import IDE.Framework.SimpleEditors -import IDE.Framework.Parameters - -import IDE.PrinterParser hiding (fieldParser, parameters) -import IDE.Framework.ViewFrame -import IDE.DescriptionPP - -concatString :: [String] -> String -concatString l = foldl (\r s -> if null r then s else r ++ " " ++ s) "" l - -flagsDescription :: [(String,[FieldDescriptionPP IDEPackage])] -flagsDescription = [ - ("Flags", [ - mkFieldPP - (paraName <<<- ParaName "Config flags" $ emptyParams) - (PP.text . show) - stringParser - (\p -> concatString (configFlags p)) - (\ b a -> a{configFlags = if null b then [] else [b]}) - stringEditor - (\ _ -> return ()) - , mkFieldPP - (paraName <<<- ParaName "Build flags" $ emptyParams) - (PP.text . show) - stringParser - (\p -> concatString (buildFlags p)) - (\ b a -> a{buildFlags = if null b then [] else [b]}) - stringEditor - (\ _ -> return ()) - , mkFieldPP - (paraName <<<- ParaName "Haddock flags" $ emptyParams) - (PP.text . show) - stringParser - (\p -> concatString (haddockFlags p)) - (\ b a -> a{haddockFlags = if null b then [] else [b]}) - stringEditor - (\ _ -> return ()) - , mkFieldPP - (paraName <<<- ParaName "Executable flags" $ emptyParams) - (PP.text . show) - stringParser - (\p -> concatString (exeFlags p)) - (\ b a -> a{exeFlags = if null b then [] else [b]}) - stringEditor - (\ _ -> return ()) - , mkFieldPP - (paraName <<<- ParaName "Install flags" $ emptyParams) - (PP.text . show) - stringParser - (\p -> concatString (installFlags p)) - (\ b a -> a{installFlags = if null b then [] else [b]}) - stringEditor - (\ _ -> return ()) - , mkFieldPP - (paraName <<<- ParaName "Register flags" $ emptyParams) - (PP.text . show) - stringParser - (\p -> concatString (registerFlags p)) - (\ b a -> a{registerFlags = if null b then [] else [b]}) - stringEditor - (\ _ -> return ()) - , mkFieldPP - (paraName <<<- ParaName "Unregister flags" $ emptyParams) - (PP.text . show) - stringParser - (\p -> concatString (unregisterFlags p)) - (\ b a -> a{unregisterFlags = if null b then [] else [b]}) - stringEditor - (\ _ -> return ()) - , mkFieldPP - (paraName <<<- ParaName "Source Distribution flags" $ emptyParams) - (PP.text . show) - stringParser - (\p -> concatString (sdistFlags p)) - (\ b a -> a{sdistFlags = if null b then [] else [b]}) - stringEditor - (\ _ -> return ()) - ])] - --- ------------------------------------------------------------ --- * Parsing --- ------------------------------------------------------------ - -readFlags :: FilePath -> IDEPackage -> IO IDEPackage -readFlags fn pack = do - res <- P.parseFromFile (flagsParser pack (concatMap snd flagsDescription)) fn - case res of - Left pe -> throwIDE $"Error reading flags file " ++ show fn ++ " " ++ show pe - Right r -> return r - -flagsParser :: a -> [FieldDescriptionPP a] -> P.CharParser () a -flagsParser def descriptions = - let parsersF = map fieldParser descriptions in do - whiteSpace - res <- applyFieldParsers def parsersF - return res - P. "flags parser" - --- ------------------------------------------------------------ --- * Printing --- ------------------------------------------------------------ - -writeFlags :: FilePath -> IDEPackage -> IO () -writeFlags fpath flags = - writeFile fpath (showFlags flags (concatMap snd flagsDescription)) - -showFlags :: a -> [FieldDescriptionPP a] -> String -showFlags flags flagsDesc = PP.render $ - foldl (\ doc (FDPP _ printer _ _ _ ) -> doc PP.$+$ printer flags) PP.empty flagsDesc - --- ------------------------------------------------------------ --- * Editing --- ------------------------------------------------------------ - -editFlags :: IDEAction -editFlags = do - ideR <- ask - mbP <- readIDE activePack - case mbP of - Nothing -> return () - Just p -> lift $editFlags' p flagsDescription ideR - - -editFlags' :: IDEPackage -> [(String,[FieldDescriptionPP IDEPackage])] -> IDERef -> IO () -editFlags' flags flagsDesc ideR = do - let flatflagsDesc = concatMap snd flagsDesc - dialog <- windowNew - vb <- vBoxNew False 0 - bb <- hButtonBoxNew - ok <- buttonNewFromStock "gtk-ok" - cancel <- buttonNewFromStock "gtk-cancel" - boxPackStart bb ok PackNatural 0 - boxPackStart bb cancel PackNatural 0 - nb <- newNotebook - notebookSetTabPos nb PosTop - res <- mapM - (\ (tabLabel, partflagsDesc) -> do - resList <- mapM (\ fd -> (fieldEditor fd) flags) partflagsDesc - let (widgetsP, setInjsP, getExtsP,notifiersP) = unzip4 resList - nbbox <- vBoxNew False 0 - mapM_ (\ w -> boxPackStart nbbox w PackNatural 0) widgetsP - sw <- scrolledWindowNew Nothing Nothing - scrolledWindowAddWithViewport sw nbbox - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - notebookAppendPage nb sw tabLabel - return (widgetsP, setInjsP, getExtsP, notifiersP)) - flagsDesc - let (widgets, setInjs, getExts, notifiers) = - foldl (\ (w,i,e,n) (w2,i2,e2,n2) -> (w ++ w2, i ++ i2, e ++ e2, n ++ n2)) ([],[],[],[]) res - let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of - Just s -> s - Nothing -> "Unnamed") flatflagsDesc - ok `onClicked` (do - mbPackWithNewFlags <- extractAndValidate flags getExts fieldNames - case mbPackWithNewFlags of - Nothing -> return () - Just packWithNewFlags -> do - runReaderT (modifyIDE_ (\ide -> return (ide{activePack = Just packWithNewFlags}))) - ideR -- we don't trigger the activePack event here - widgetDestroy dialog - mainQuit) - cancel `onClicked` (do - widgetDestroy dialog - mainQuit) - boxPackStart vb nb PackGrow 7 - boxPackEnd vb bb PackNatural 7 - containerAdd dialog vb - widgetSetSizeRequest dialog 500 700 - widgetShowAll dialog - mainGUI - return () - - - - - - - diff --git a/src/IDE/Pane/Callers.hs b/src/IDE/Pane/Callers.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Pane/Callers.hs @@ -0,0 +1,288 @@ +{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Pane.Callers +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | The pane of ide where modules are presented in tree form with their +-- packages and exports +-- +------------------------------------------------------------------------------- + +module IDE.Pane.Callers ( + IDECallers(..) +, CallersState +, calledBy +, showCallers +) where + +import Graphics.UI.Gtk hiding (get) +import Graphics.UI.Gtk.ModelView as New +import IDE.Find (focusFindEntry,showFindbar,setFindState,entryStr, getFindState, editFind) +import IDE.Pane.SourceBuffer (selectSourceBuf) +import Graphics.UI.Gtk.Gdk.Events +import Data.IORef (newIORef,writeIORef,readIORef,IORef(..)) +import Data.Maybe +import Control.Monad.Reader +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.List +import Data.Typeable +import Distribution.ModuleName(ModuleName) +import Distribution.Text +import Text.PrettyPrint (render) + +import IDE.Core.State + + +-- | A callers pane description +-- + +data IDECallers = IDECallers { + scrolledView :: ScrolledWindow +, treeViewC :: New.TreeView +, callersDescr :: IORef (Maybe Descr) +, callersStore :: New.ListStore (ModuleDescr,Symbol) +, callersEntry :: Entry +, topBox :: VBox +} deriving Typeable + +data CallersState = CallersState (Maybe Descr) + deriving(Eq,Ord,Read,Show,Typeable) + + +instance IDEObject IDECallers + +instance Pane IDECallers IDEM + where + primPaneName _ = "Usage" + getAddedIndex _ = 0 + getTopWidget = castToWidget . topBox + paneId b = "*Usage" + makeActive p = activatePane p [] + close pane = do + (panePath,_) <- guiPropertiesFromName (paneName pane) + nb <- getNotebook panePath + mbI <- liftIO $notebookPageNum nb (getTopWidget pane) + case mbI of + Nothing -> liftIO $ do + sysMessage Normal "notebook page not found: unexpected" + return () + Just i -> do + deactivatePaneIfActive pane + liftIO $ do + notebookRemovePage nb i + widgetDestroy (getTopWidget pane) + removePaneAdmin pane + +-- | We don't recover this pane +instance RecoverablePane IDECallers CallersState IDEM where + saveState p = do + mbDescr <- liftIO $ readIORef (callersDescr p) + return (Just (CallersState mbDescr)) + recoverState pp (CallersState mbDescr) = do + nb <- getNotebook pp + initCallers pp nb + when (isJust mbDescr) (calledBy (fromJust mbDescr)) + +showCallers :: IDEAction +showCallers = do + m <- getCallers + liftIO $ bringPaneToFront m + liftIO $ widgetGrabFocus (treeViewC m) + + +-- | Open a pane with the callers of this identifier +calledBy :: Descr -> IDEAction +calledBy idDescr = do + mbCurrentInfo <- readIDE currentInfo + case mbCurrentInfo of + Nothing -> return () + Just currentInfo' -> + let symModPair = (descrName idDescr, modu $ descrModu idDescr) + modulesList1 = modulesForCallerFromPackages + (Map.elems $ fst $ fst currentInfo') symModPair + modulesList2 = modulesForCallerFromPackages + (Map.elems $ fst $ snd currentInfo') symModPair + modulesList = nub $ modulesList1 ++ modulesList2 + finalList = sort $ zip modulesList (repeat (descrName idDescr)) + in do callers <- getCallers + liftIO $ do + writeIORef (callersDescr callers) (Just idDescr) + New.listStoreClear (callersStore callers) + mapM_ (New.listStoreAppend (callersStore callers)) finalList + entrySetText (callersEntry callers) + $ descrName idDescr ++ + " << " ++ showPackModule (descrModu idDescr) + bringPaneToFront callers + +modulesForCallerFromPackages :: [PackageDescr] -> (Symbol,ModuleName) -> [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 + 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 + 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 + panes <- readIDE panes + paneMap <- readIDE paneMap + prefs <- readIDE prefs + currentInfo <- readIDE currentInfo + (buf,cids) <- reifyIDE $ \ideR session -> do + listStore <- New.listStoreNew [] + treeView <- New.treeViewNew + New.treeViewSetModel treeView listStore + + renderer0 <- New.cellRendererPixbufNew + set renderer0 [ cellPixbufStockId := stockYes ] + + renderer <- New.cellRendererTextNew + col <- New.treeViewColumnNew + New.treeViewColumnSetTitle col "Modules" + New.treeViewColumnSetSizing col TreeViewColumnAutosize + New.treeViewColumnSetResizable col True + New.treeViewColumnSetReorderable col True + New.treeViewAppendColumn treeView col + New.cellLayoutPackStart col renderer0 False + New.cellLayoutPackStart col renderer True + New.cellLayoutSetAttributes col renderer listStore + $ \row -> [ New.cellText := render $ disp $ modu $ moduleIdMD $ fst row] + New.cellLayoutSetAttributes col renderer0 listStore + $ \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.treeViewColumnSetResizable col True + New.treeViewColumnSetReorderable col2 True + New.treeViewAppendColumn treeView col2 + New.cellLayoutPackStart col2 renderer2 True + New.cellLayoutSetAttributes col2 renderer2 listStore + $ \row -> [ New.cellText := render $ disp $ pack $ moduleIdMD $ fst row] + + New.treeViewSetHeadersVisible treeView True + sel <- New.treeViewGetSelection treeView + New.treeSelectionSetMode sel SelectionSingle + + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw treeView + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + entry <- entryNew + set entry [ entryEditable := False ] + box <- vBoxNew False 2 + boxPackStart box entry PackNatural 0 + boxPackEnd box sw PackGrow 0 + callersDescr' <- newIORef Nothing + let callers = IDECallers sw treeView callersDescr' listStore entry box + notebookInsertOrdered nb box (paneName callers) Nothing + widgetShowAll box + cid1 <- treeView `afterFocusIn` + (\_ -> do reflectIDE (makeActive callers) ideR session; return True) + treeView `onButtonPress` (treeViewPopup ideR session callers) + return (callers,[ConnectC cid1]) + addPaneAdmin buf cids panePath + liftIO $widgetGrabFocus (scrolledView buf) + + +getSelectionTree :: New.TreeView + -> New.ListStore (ModuleDescr,Symbol) + -> IO (Maybe (ModuleDescr,Symbol)) +getSelectionTree treeView listStore = do + treeSelection <- New.treeViewGetSelection treeView + rows <- New.treeSelectionGetSelectedRows treeSelection + case rows of + [[n]] -> do + val <- New.listStoreGetValue listStore n + return (Just val) + _ -> return Nothing + +treeViewPopup :: IDERef + -> Session + -> IDECallers + -> Event + -> IO (Bool) +treeViewPopup ideR session callers (Button _ click _ _ _ _ button _ _) = do + if button == RightButton + then do + theMenu <- menuNew + item1 <- menuItemNewWithLabel "Edit" + item1 `onActivateLeaf` do + sel <- getSelectionTree (treeViewC callers) (callersStore callers) + case sel of + Just (m,_) -> case mbSourcePathMD m of + Nothing -> return () + Just fp -> do + text <- entryGetText (callersEntry callers) + case words text of + (hd : tl) -> do + reflectIDE (selectText fp hd) ideR session + return () + _ -> return () + otherwise -> return () + menuShellAppend theMenu item1 + menuPopup theMenu Nothing + widgetShowAll theMenu + return True + else if button == LeftButton && click == DoubleClick + then do sel <- getSelectionTree (treeViewC callers) + (callersStore callers) + case sel of + Just (m,_) + -> case mbSourcePathMD m of + Nothing -> return False + Just fp -> do + text <- entryGetText (callersEntry callers) + case words text of + (hd : tl) -> do + reflectIDE (selectText fp hd) ideR session + return True + _ -> return False + otherwise -> return False + else return False +treeViewPopup _ _ _ _ = throwIDE "treeViewPopup wrong event type" + +selectText :: FilePath -> String -> IDEM Bool +selectText fp text = do + res <- selectSourceBuf fp + fs <- getFindState + case res of + Nothing -> return False + Just _ -> do + setFindState fs {entryStr = text} + showFindbar + focusFindEntry + reifyIDE $ \ideR session -> do + idleAdd (do + reflectIDE (editFind True True True text "" Forward) ideR session + return False) + priorityDefaultIdle + return True + + diff --git a/src/IDE/Pane/ClassHierarchy.hs b/src/IDE/Pane/ClassHierarchy.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Pane/ClassHierarchy.hs @@ -0,0 +1,919 @@ +{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances + -XScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Pane.ClassHierarchy +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | The pane of ide where modules are presented in tree form with their +-- packages and exports +-- +------------------------------------------------------------------------------- + +module IDE.Pane.ClassHierarchy ( + IDEClassHierarchy(..) +, ClassHierarchyState(..) +, showClasses +--, showInstances +, selectClass +--, 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 Data.Typeable +import Prelude hiding (catch) + + +import IDE.Core.State + +-- | A modules pane description +-- + +data IDEClassHierarchy = IDEClassHierarchy { + outer :: VBox +, paned :: HPaned +, treeView :: New.TreeView +, treeStore :: New.TreeStore ClassWrapper +--, facetView :: New.TreeView +--, facetStore :: New.TreeStore FacetWrapper +, localScopeB :: RadioButton +, packageScopeB :: RadioButton +, worldScopeB :: RadioButton +, blacklistB :: CheckButton +} deriving Typeable + +data ClassHierarchyState = ClassHierarchyState Int (Scope,Bool) + (Maybe String, Maybe String) + deriving(Eq,Ord,Read,Show,Typeable) + +instance IDEObject IDEClassHierarchy + +instance Pane IDEClassHierarchy IDEM + where + primPaneName _ = "ClassHierarchy" + getAddedIndex _ = 0 + getTopWidget = castToWidget . outer + paneId b = "*ClassHierarchy" + makeActive p = activatePane p [] + close pane = do + (panePath,_) <- guiPropertiesFromName (paneName pane) + nb <- getNotebook panePath + mbI <- liftIO $notebookPageNum nb (getTopWidget pane) + case mbI of + Nothing -> throwIDE "Pane>IDEClassHierarchy: notebook page not found: unexpected" + Just i -> do + deactivatePaneIfActive pane + liftIO $ do + notebookRemovePage nb i + widgetDestroy (getTopWidget pane) + removePaneAdmin pane + +instance RecoverablePane IDEClassHierarchy ClassHierarchyState IDEM where + saveState p = return Nothing + recoverState pp _ = return () + +{-- +instance RecoverablePane IDEClassHierarchy ClassHierarchyState where + saveState p = do + (IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) <- getModules + sc <- getScope + mbModules <- getPane + case mbModules of + Nothing -> return Nothing + Just p -> liftIO $ 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 (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 -> liftIO $ toggleButtonSetActive lb True + Package -> liftIO $ toggleButtonSetActive pb True + World -> liftIO $ toggleButtonSetActive wb True + liftIO $ toggleButtonSetActive blb useBlacklist + liftIO $ panedSetPosition (paned mod) i + fillModulesList sc + selectNames se +--} + + +selectClass :: Descr -> IDEAction +selectClass d@(Descr descrName _ descrModu _ _ details) = + case details of + (ClassDescr _ _)-> selectClass' (modu descrModu) descrName + _ -> return () +selectClass _ = return () + +selectClass' moduleName symbol = return () +{-- +selectClass' :: ModuleIdentifier -> Symbol -> IDEAction +selectClass' moduleName symbol = + let nameArray = breakAtDots [] moduleName + in do + mods@(IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) <- getModules + mbTree <- liftIO $ treeStoreGetTreeSave treeStore [] + case treePathFromNameArray mbTree nameArray [] of + Just treePath -> liftIO $ 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)) + mbFacetTree <- treeStoreGetTreeSave facetStore [] + selF <- New.treeViewGetSelection facetView + case findPathFor symbol mbFacetTree 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 () +--} + +showClasses :: IDEAction +showClasses = do + m <- getClassHierarchy + liftIO $ bringPaneToFront m + liftIO $ widgetGrabFocus (treeView m) + +--showInstances :: IDEAction +--showInstances = do +-- m <- getClassHierarchy +-- liftIO $ bringPaneToFront m +-- liftIO $ widgetGrabFocus (facetView m) + +getClassHierarchy :: IDEM IDEClassHierarchy +getClassHierarchy = do + mbCH <- getPane + case mbCH of + Nothing -> do + prefs <- readIDE prefs + layout <- readIDE layout + let pp = getStandardPanePath (modulesPanePath prefs) layout + nb <- getNotebook pp + initClassHierarchy pp nb + mbCH <- getPane + case mbCH of + Nothing -> throwIDE "Can't init class hierarchy" + Just m -> return m + Just m -> return m + +type ClassHierarchy = Forest ClassWrapper +type ClassWrapper = (Symbol, [Symbol], Descr) + +-- +-- | Make a Tree with a class hierarchy for display. +-- +buildClassHierarchyTree :: (PackageScope,PackageScope) -> ClassHierarchy +buildClassHierarchyTree ((_,sc1),(_,sc2)) = + let allClasses = nub + $ filter isClassDescr + $ concat (Map.elems sc1) + ++ concat (Map.elems sc2) + wrappers = map asClassWrapper allClasses + (basics,other) = partition (\(_,sc,_) -> null sc) wrappers + basicForest = map (\ n -> Node n []) basics + resultForest = insertInForest basicForest other + in sortForest resultForest + where + insertInForest :: ClassHierarchy -> [ClassWrapper] -> ClassHierarchy + insertInForest basicForest [] = basicForest + insertInForest basicForest other = + let (newForest,rest) = foldl' insertInForest' (basicForest,[]) other + in if length rest >= length other + then throwIDE "ClassHierarchy>>buildClassHierarchyTree: Can't build tree" + else insertInForest newForest rest + + insertInForest' :: (ClassHierarchy,[ClassWrapper]) -> ClassWrapper + -> (ClassHierarchy,[ClassWrapper]) + insertInForest' (forest,rest) wrap@(id,superList,idDescr) = + let (newForest,newSuperList) = foldl' (insertInForest2 wrap) + (forest, []) superList + in if null newSuperList + then (newForest,rest) + else (newForest,(id,newSuperList,idDescr): rest) + + insertInForest2 :: ClassWrapper -> (ClassHierarchy,[String]) -> String + -> (ClassHierarchy,[String]) + insertInForest2 wrapper (forest,rest) super = + let (newForest,success) = foldl' (insertInTree wrapper super) ([],False) forest + in if success + then (newForest,rest) + else (newForest, super : rest) + + insertInTree :: ClassWrapper -> String -> (ClassHierarchy,Bool) + -> Tree ClassWrapper -> (ClassHierarchy,Bool) + insertInTree wrapper superS (forest,bool) n@(Node w@(symbol,super,idDescr) subForest) = + if superS == symbol + then (Node w ((Node wrapper []) : subForest) : forest, True) + else + let (newSubForest,newBool) = foldl' (insertInTree wrapper superS) ([],False) + subForest + in if newBool + then ((Node w newSubForest) : forest, True) + else (n: forest, bool) + + +isClassDescr :: Descr -> Bool +isClassDescr descr = case details descr of + ClassDescr _ _ -> True + _ -> False +asClassWrapper :: Descr -> ClassWrapper +asClassWrapper descr = + case details descr of + ClassDescr super _ -> (descrName descr, super, descr) + _ -> throwIDE "ClassHierarchy>>asClassWrapper: No class" + +instance Ord a => Ord (Tree a) where + compare (Node l1 _) (Node l2 _) = compare l1 l2 + +sortForest :: Ord a => Forest a -> Forest a +sortForest forest = sort (map sortTree forest) + +sortTree :: Ord a => Tree a -> Tree a +sortTree (Node l forest) = Node l (sort (map sortTree forest)) + +initClassHierarchy :: PanePath -> Notebook -> IDEAction +initClassHierarchy panePath nb = do + panes <- readIDE panes + paneMap <- readIDE paneMap + prefs <- readIDE prefs + currentInfo <- readIDE currentInfo + (buf,cids) <- reifyIDE $ \ideR session -> do + +-- Class Hierarchy + let forest = case currentInfo of + Nothing -> [] + Just pair -> buildClassHierarchyTree pair + treeStore <- New.treeStoreNew forest + treeView <- New.treeViewNew + New.treeViewSetModel treeView treeStore + --New.treeViewSetRulesHint treeView True + + renderer0 <- New.cellRendererPixbufNew + set renderer0 [ cellPixbufStockId := "ide_no_source" ] + + renderer <- New.cellRendererTextNew + col <- New.treeViewColumnNew + New.treeViewColumnSetTitle col "Classes" + New.treeViewColumnSetSizing col TreeViewColumnAutosize + New.treeViewColumnSetResizable col True + New.treeViewColumnSetReorderable col True + New.treeViewAppendColumn treeView col + New.cellLayoutPackStart col renderer0 False + New.cellLayoutPackStart col renderer True + New.cellLayoutSetAttributes col renderer treeStore + $ \(s,_,_) -> [ New.cellText := s] + New.cellLayoutSetAttributes col renderer0 treeStore + $ \(_,_,d) -> [ + cellPixbufStockId := + if isJust (mbLocation d) + then "ide_source" + else "ide_no_source"] + + New.treeViewSetHeadersVisible treeView True + -- New.treeViewSetEnableSearch treeView True + -- New.treeViewSetSearchColumn treeView 0 + -- New.treeViewSetSearchEqualFunc treeView (treeViewSearch treeView treeStore) + +-- Facet view +{-- + facetView <- New.treeViewNew + facetStore <- New.treeStoreNew [] + New.treeViewSetModel facetView facetStore + 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 facetView True + New.treeViewSetEnableSearch facetView True + New.treeViewSetSearchColumn facetView 0 + New.treeViewSetSearchEqualFunc facetView (facetViewSearch facetView facetStore) +--} + 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" + toggleButtonSetActive rb3 True + 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 classes = IDEClassHierarchy boxOuter pane' treeView treeStore + {--facetView facetStore--} rb1 rb2 rb3 cb + notebookInsertOrdered nb boxOuter (paneName classes) Nothing + widgetShowAll boxOuter + cid3 <- treeView `New.onRowActivated` + (\ treePath _ -> do + New.treeViewExpandRow treeView treePath False + return ()) + cid1 <- treeView `afterFocusIn` + (\_ -> do reflectIDE (makeActive classes) ideR session; return True) +-- cid2 <- facetView `afterFocusIn` +-- (\_ -> do runReaderT (makeActive classes) 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 facetView facetStore) +-- sel2 <- New.treeViewGetSelection facetView +-- sel2 `New.onSelectionChanged` (fillInfo facetView facetStore ideR) + + return (classes,[ConnectC cid1{--,ConnectC cid2--}, ConnectC cid3]) + addPaneAdmin buf cids panePath + liftIO $widgetGrabFocus (paned buf) + + +{-- +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 + mbTree <- treeStoreGetTreeSave treeStore path + exp <- New.treeViewRowExpanded treeView path + when (isJust mbTree && (not (null (subForest (fromJust mbTree)))) && not exp) $ + let found = searchInModSubnodes (fromJust mbTree) 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)) + +searchInModSubnodes :: ModTree -> String -> Bool +searchInModSubnodes 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) + +facetViewSearch :: TreeView + -> New.TreeStore FacetWrapper + -> Int + -> String + -> TreeIter + -> IO Bool +facetViewSearch facetView facetStore _ string iter = do + path <- New.treeModelGetPath facetStore iter + val <- New.treeStoreGetValue facetStore path + tree <- New.treeStoreGetTree facetStore path + exp <- New.treeViewRowExpanded facetView path + when (not (null (subForest tree)) && not exp) $ + let found = searchInFacetSubnodes tree string + in when found $ do + New.treeViewExpandRow facetView path False + return () + return (isInfixOf (map toLower string) (map toLower (facetTreeText val))) + +searchInFacetSubnodes :: FacetTree -> String -> Bool +searchInFacetSubnodes tree str = + not $ null + $ filter (\ val -> + isInfixOf (map toLower str) (map toLower (facetTreeText val))) + $ concatMap flatten (subForest tree) +--} + +{-- +fillFacets :: New.TreeView + -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) + -> New.TreeView + -> New.TreeStore FacetWrapper + -> IO () +fillFacets treeView treeStore facetView facetStore = do + sel <- getSelectionTree treeView treeStore + case sel of + Just val + -> case snd val of + ((mod,package):_) + -> let forest = buildFacetForest mod in do + emptyModel <- New.treeStoreNew [] + New.treeViewSetModel facetView emptyModel + New.treeStoreClear facetStore + mapM_ (\(e,i) -> New.treeStoreInsertTree facetStore [] i e) + $ zip forest [0 .. length forest] + New.treeViewSetModel facetView facetStore + New.treeViewSetEnableSearch facetView True + New.treeViewSetSearchColumn facetView 0 + New.treeViewSetSearchEqualFunc facetView (facetViewSearch facetView facetStore) + + [] -> return () + Nothing + -> do + New.treeStoreClear facetStore + return () +--} +{-- +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 liftIO $ do + New.treeStoreClear treeStore + mapM_ (\(e,i) -> New.treeStoreInsertTree treeStore [] i e) + $ zip li [0 .. length li] + _ -> liftIO $ do + New.treeStoreClear treeStore + New.treeStoreInsertTree treeStore [] 0 (Node ("",[]) []) + 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 liftIO $ 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.treeViewSetEnableSearch treeView True + New.treeViewSetSearchColumn treeView 0 + New.treeViewSetSearchEqualFunc treeView (treeViewSearch treeView treeStore) + + 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 + +buildFacetForest :: ModuleDescr -> FacetForest +buildFacetForest 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) + + + +--} + +{-- +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 + mbPane :: Maybe IDEInfo <- runReaderT getPane ideR + when (isJust mbPane) $ bringPaneToFront (fromJust mbPane) + 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 <- liftIO $ toggleButtonGetActive localScopeB + rb2s <- liftIO $ toggleButtonGetActive packageScopeB + rb3s <- liftIO $ toggleButtonGetActive worldScopeB + cbs <- liftIO $ 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 <- liftIO $ getSelectionTree treeView treeStore + mbFacetSelection <- liftIO $ getSelectionFacet facetView facetStore + + sc <- getScope + ts <- liftIO $ New.treeViewGetSelection treeView + liftIO $ 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 + liftIO $ 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 + mbTree <- liftIO $ treeStoreGetTreeSave treeStore [] + case treePathFromNameArray mbTree nameArray [] of + Nothing -> return () + Just treePath -> liftIO $ 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 + mbFacetTree <- treeStoreGetTreeSave facetStore [] + selF <- New.treeViewGetSelection facetView + case findPathFor symbol mbFacetTree 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 + case mbMod of + Nothing -> return () + Just mods@(IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) + -> do + mbTreeSelection <- liftIO $ getSelectionTree treeView treeStore + mbFacetSelection <- liftIO $ getSelectionFacet facetView facetStore + sc <- getScope + fillModulesList sc + liftIO $ 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 + + +treeStoreGetTreeSave :: New.TreeStore a -> TreePath -> IO (Maybe (Tree a)) +treeStoreGetTreeSave treeStore treePath = catch (do + res <- treeStoreGetTree treeStore treePath + return (Just res)) (\ _ -> return Nothing) + + +findPathFor :: Symbol -> Maybe (Tree FacetWrapper) -> Maybe TreePath +findPathFor symbol (Just (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)] +findPathFor symbol Nothing = Nothing + +treePathFromNameArray :: Maybe ModTree -> [String] -> [Int] -> Maybe [Int] +treePathFromNameArray (Just tree) [] accu = Just (reverse accu) +treePathFromNameArray (Just 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 (Just (subForest tree !! i)) t (i:accu) +treePathFromNameArray Nothing _ _ = Nothing + +--} +{-- +extractSuperclasses :: String -> [String] +extractSuperclasses str = + let parseRes = trace ("now extracting superclasses for " ++ show str) + parse superclassParser "" str + in case parseRes of + Left err -> throwIDE $show err + Right l -> trace ("found " ++ show l) l + +lexer = haskell +lexeme = P.lexeme lexer +whiteSpace = P.whiteSpace lexer +symbol = P.symbol lexer + +superclassParser :: CharParser () [String] +superclassParser = do + symbol "class" + whiteSpace + try (do + sc <- classDefParser + symbol "=>" + return [sc]) + <|> try (do + symbol "(" + scs <- sepBy classDefParser (char ',') + symbol ")" + symbol "=>" + return scs) + <|> return [] + "superclasses" + +classDefParser :: CharParser () String +classDefParser = do + whiteSpace + c <- oneOf['A'..'Z'] + cs <- many (alphaNum <|> oneOf "_'.") + many typeVarParser + return (c:cs) + "classDef" + +typeVarParser :: CharParser () String +typeVarParser = do + whiteSpace + c <- oneOf['a'..'z'] + cs <- many (alphaNum <|> oneOf "_'.") + return (c:cs) + "typeVar" +--} diff --git a/src/IDE/Pane/Info.hs b/src/IDE/Pane/Info.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Pane/Info.hs @@ -0,0 +1,345 @@ +{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses + -XScopedTypeVariables -XTypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Pane.Info +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | The GUI stuff for infos +-- +------------------------------------------------------------------------------- + +module IDE.Pane.Info ( + IDEInfo +, InfoState +, setInfo +, setSymbol +, replayInfoHistory +, getIdentifierDescr +, showInfo +) 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 +import qualified Data.Map as Map +import Data.Typeable + +import IDE.Core.State +import Control.Event +import Graphics.UI.Editor.MakeEditor +import Graphics.UI.Editor.Simple +import Graphics.UI.Editor.Composite +import Graphics.UI.Editor.Parameters +import IDE.Pane.SourceBuffer +import IDE.Pane.Callers +import Graphics.UI.Editor.Basics +import MyMissing + + + +-- | An info pane description +-- +data IDEInfo = IDEInfo { + sw :: ScrolledWindow +, currentDescr :: IORef Descr +, injector :: Descr -> IO() +, extractor :: Descr -> Extractor Descr +} deriving Typeable + +data InfoState = InfoState Descr + deriving(Eq,Ord,Read,Show,Typeable) + + +instance IDEObject IDEInfo + +instance Pane IDEInfo IDEM + where + primPaneName _ = "Info" + getAddedIndex _ = 0 + getTopWidget = castToWidget . sw + paneId b = "*Info" + makeActive pane = activatePane pane [] + close pane = do + (panePath,_) <- guiPropertiesFromName (paneName pane) + nb <- getNotebook panePath + mbI <- liftIO $notebookPageNum nb (getTopWidget pane) + case mbI of + Nothing -> liftIO $ do + sysMessage Normal "notebook page not found: unexpected" + return () + Just i -> do + deactivatePaneIfActive pane + liftIO $ do + notebookRemovePage nb i + widgetDestroy (getTopWidget pane) + removePaneAdmin pane + +instance RecoverablePane IDEInfo InfoState IDEM where + saveState p = do + currentDescr' <- liftIO $ readIORef (currentDescr p) + return (Just (InfoState currentDescr')) + recoverState pp (InfoState descr) = do + setInfo descr + +showInfo :: IDEAction +showInfo = do + mbInfo :: Maybe IDEInfo <- getPane + case mbInfo of + Nothing -> return () + Just p -> liftIO $ bringPaneToFront p + +idDescrDescr :: IDERef -> Session -> FieldDescription Descr +idDescrDescr ideR session = VFD emptyParams [ + HFD emptyParams [ + mkField + (paraName <<<- ParaName "Identifier" + $ paraName <<<- ParaPack PackGrow + $ emptyParams) + descrName + (\ b a -> if isReexported a then a else a{descrName' = b}) + (symbolEditor ideR session) + , mkField + emptyParams + (stockIdFromType . descrType . details) + (\b a -> a) + imageEditor + , mkField + (paraName <<<- ParaName "Sort" + $ emptyParams) + (descrType . details) + (\b a -> a) + (comboSelectionEditor allOf) + , mkField + (paraName <<<- ParaName "Exported by" + $ paraPack <<<- ParaPack PackGrow + $ emptyParams) + (\l -> showPackModule (descrModu l)) + (\ b a -> if isReexported a then a else a{descrModu' = parsePackModule b}) + (stringEditor (const True))] + , mkField + (paraPack <<<- ParaPack PackGrow $ emptyParams) + (\ a -> (BS.unpack $ typeInfo a, + (case mbComment a of + Nothing -> "" + Just s -> BS.unpack s))) + (\ b a -> + (if isReexported a + then a + else a {typeInfo' = BS.pack (fst b), + mbComment' = case snd b of + "" -> Nothing + s -> Just (BS.pack s)})) + (typeAndCommentEditor ideR session)] + +--allIdTypes = [Function, Newtype, Type, AbstractData, OpenData, Foreign +-- , Data, Class, Instance, Constructor, Field, Method, OrphanedInstance] + +typeEditor :: IDERef -> Session -> Editor String +typeEditor ideR session para noti = do + ed@(wid,inj,ext) <- multilineStringEditor para noti + registerEvent noti ButtonRelease $Left (\e -> do + res <- showInfoHandler wid ideR session + return e {gtkReturn = res}) + return ed + +typeAndCommentEditor :: IDERef -> Session -> Editor (String,String) +typeAndCommentEditor ideR session para noti = + splitEditor (typeEditor ideR session, + paraName <<<- ParaName "Type" + $ paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0) + $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0) + $ emptyParams) + (multilineStringEditor, + paraName <<<- ParaName "Comment" + $ paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0) + $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0) + $ emptyParams) + (paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0) + $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0) + $ para) noti + +symbolEditor :: IDERef -> Session -> Editor String +symbolEditor ideR session parameters notifier = do + window <- reflectIDE (readIDE window) ideR session + ed@(w,i,ext) <- stringEditor (\_ -> True) parameters notifier + registerEvent notifier AfterKeyRelease (Left (\event -> do + mbText <- ext + case mbText of + Just t -> do + reflectIDE (do + triggerEvent ideR (SearchMeta t) + rw <- liftIO $ getRealWidget w + when (isJust rw) $ liftIO $ do + widgetGrabFocus (fromJust rw) + editableSelectRegion (castToEditable (fromJust rw)) 0 0 + editableSetPosition (castToEditable (fromJust rw)) (-1)) ideR session + Nothing -> return () + return event)) + return ed + +showInfoHandler :: Widget -> IDERef -> Session -> IO Bool +showInfoHandler wid ideR session = 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 + reflectIDE (triggerEvent ideR (SelectInfo symbol)) ideR session + return False + +initInfo :: PanePath -> Notebook -> Descr -> IDEAction +initInfo panePath nb idDescr = do + panes <- readIDE panes + paneMap <- readIDE paneMap + prefs <- readIDE prefs + (pane,cids) <- reifyIDE $ \ideR session -> do + ibox <- vBoxNew False 0 + bb <- hButtonBoxNew + buttonBoxSetLayout bb ButtonboxSpread + definitionB <- buttonNewWithLabel "Source" + moduB <- buttonNewWithLabel "Modules" + usesB <- buttonNewWithLabel "Usage" + docuB <- buttonNewWithLabel "Docu" + searchB <- buttonNewWithLabel "Find" + widgetSetSensitivity docuB False + boxPackStartDefaults bb definitionB + boxPackStartDefaults bb moduB + boxPackStartDefaults bb usesB + boxPackStartDefaults bb docuB + boxPackStartDefaults bb searchB + (widget,injb,ext,notifier) <- buildEditor (idDescrDescr ideR session) idDescr + boxPackStart ibox widget PackGrow 0 + boxPackEnd ibox bb PackNatural 0 + --openType + sw <- scrolledWindowNew Nothing Nothing + scrolledWindowAddWithViewport sw ibox + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + currentDescr' <- newIORef idDescr + let info = IDEInfo sw currentDescr' injb ext + -- mapM_ (\w -> widgetSetExtensionEvents w [ExtensionEventsAll]) widgets + widget `onFocus` (\_ -> do reflectIDE (makeActive info) ideR session + return False) + definitionB `onClicked` (reflectIDE gotoSource ideR session) + moduB `onClicked` (reflectIDE gotoModule' ideR session) + usesB `onClicked` (reflectIDE calledBy' ideR session) + searchB `onClicked` (do + mbDescr <- ext idDescr + case mbDescr of + Nothing -> return () + Just descr -> reflectIDE (do + triggerEvent ideR (SearchMeta (descrName' descr)) + showInfo) ideR session) + notebookInsertOrdered nb sw (paneName info) Nothing + widgetShowAll sw + return (info,[]) + addPaneAdmin pane [] panePath + liftIO $widgetGrabFocus (sw pane) + liftIO $bringPaneToFront pane + +gotoSource :: IDEAction +gotoSource = do + mbInfo <- getInfoCont + case mbInfo of + Nothing -> do ideMessage Normal "gotoSource:noDefition" + return () + Just info -> goToDefinition info >> return () + +gotoModule' :: IDEAction +gotoModule' = do + mbInfo <- getInfoCont + ideR <- ask + case mbInfo of + Nothing -> return () + Just info -> triggerEvent ideR (SelectIdent info) >> return () + +calledBy' :: IDEAction +calledBy' = do + mbInfo <- getInfoCont + case mbInfo of + Nothing -> return () + Just info -> calledBy info >> return () + +setSymbol :: String -> IDEAction +setSymbol symbol = do + ideR <- ask + currentInfo' <- readIDE currentInfo + case currentInfo' of + Nothing -> return () + Just ((_,symbolTable1),(_,symbolTable2)) -> + case getIdentifierDescr symbol symbolTable1 symbolTable2 of + [] -> return () + (a:r) -> do + setInfo a + showInfo + if length (a:r) > 1 + then triggerEvent ideR (DescrChoice (a:r)) >> return () + else triggerEvent ideR (SelectIdent a) >> return () + + +setInfo :: Descr -> IDEAction +setInfo identifierDescr = do + mbPane <- getPane + case mbPane of + Nothing -> do + prefs <- readIDE prefs + layout <- readIDE layout + let pp = getStandardPanePath (logPanePath prefs) layout + nb <- getNotebook pp + initInfo pp nb identifierDescr + Just info -> do + oldDescr <- liftIO $ readIORef (currentDescr info) + liftIO $ do + writeIORef (currentDescr info) identifierDescr + (injector info) identifierDescr + recordInfoHistory identifierDescr oldDescr + +getInfoCont :: IDEM (Maybe (Descr)) +getInfoCont = do + mbPane <- getPane + case mbPane of + Nothing -> return Nothing + Just p -> liftIO $ readIORef (currentDescr p) >>= return . Just + +-- +-- | Lookup of an identifier description +-- +getIdentifierDescr :: String -> SymbolTable -> SymbolTable -> [Descr] +getIdentifierDescr str st1 st2 = + let r1 = case str `Map.lookup` st1 of + Nothing -> [] + Just r -> r + r2 = case str `Map.lookup` st2 of + Nothing -> [] + Just r -> r + in r1 ++ r2 + +-- * GUI History + +recordInfoHistory :: Descr -> Descr -> IDEAction +recordInfoHistory descr oldDescr = do + ideR <- ask + triggerEvent ideR (RecordHistory + ((InfoElementSelected descr), + (InfoElementSelected oldDescr))) + return () + +replayInfoHistory :: Descr -> IDEAction +replayInfoHistory descr = do + setInfo descr + + diff --git a/src/IDE/Pane/Log.hs b/src/IDE/Pane/Log.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Pane/Log.hs @@ -0,0 +1,707 @@ +{-# OPTIONS_GHC -XScopedTypeVariables -XDeriveDataTypeable -XMultiParamTypeClasses + -XTypeSynonymInstances -XParallelListComp #-} +-- +-- Module : IDE.Pane.Log +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | Log pane +-- +------------------------------------------------------------------------------- + + +module IDE.Pane.Log ( + IDELog(..) +, LogView(..) +, LogAction(..) +, LogState +, LogTag(..) + +, readOut +, readErr +, runExternal +) where + +import Data.Typeable (Typeable(..)) +import Text.ParserCombinators.Parsec +import IDE.Core.State +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Gdk.Events +import Graphics.UI.Editor.MakeEditor (buildEditor) +import Control.Monad.Trans (liftIO) +import Graphics.UI.Editor.Basics (eventPaneName) +import Graphics.UI.Editor.Basics (GUIEventSelector(..)) +import Control.Event (registerEvent) +import Graphics.UI.Editor.Simple (okCancelFields) +import Graphics.UI.Editor.Parameters +import Text.ParserCombinators.Parsec.Language (haskellDef) +import Data.Char (isUpper) +import qualified Text.ParserCombinators.Parsec.Token as P +import Text.ParserCombinators.Parsec.Language (haskellStyle) +import Data.List (foldl',sort,nub) +import IDE.SourceCandy (getCandylessText) +import IDE.Pane.SourceBuffer (inBufContext') +import IDE.Pane.Info (getIdentifierDescr) +import Debug.Trace (trace) +import Data.List (nubBy) +import IDE.Pane.SourceBuffer (markErrorInSourceBuf) +import IDE.Pane.SourceBuffer (selectSourceBuf) +import Graphics.UI.Editor.MakeEditor (FieldDescription(..),mkField) +import Graphics.UI.Editor.Simple (staticListEditor) +import Data.Maybe (isNothing,isJust) +import Distribution.ModuleName(ModuleName) +import Distribution.Text(disp) +import Text.PrettyPrint (render) +import System.Process +import System.IO +import Prelude hiding (catch) +import Control.Exception hiding (try) +------------------------------------------------------------------------------- +-- +-- * Interface +-- + +-- +-- | The Log pane +-- + + +data IDELog = IDELog { + textView :: TextView +, scrolledWindowL :: ScrolledWindow +} deriving Typeable + +data LogState = LogState + deriving(Eq,Ord,Read,Show,Typeable) + + +class LogAction alpha where + clearLog :: alpha + addAllImports :: alpha + addOneImport :: alpha + +instance LogAction IDEAction where + clearLog = clearLog' + addAllImports = addAllImports' + addOneImport = addOneImport' + +class Pane alpha beta => LogView alpha beta where + getLog :: beta alpha + appendLog :: alpha -> String -> LogTag -> IO Int + markErrorInLog :: alpha -> (Int, Int) -> IO () + +instance IDEObject IDELog + +instance LogView IDELog IDEM + where + getLog = getLog' + appendLog = appendLog' + markErrorInLog = markErrorInLog' + +instance Pane IDELog IDEM + where + primPaneName _ = "Log" + getAddedIndex _ = 0 + getTopWidget = castToWidget . scrolledWindowL + paneId b = "*Log" + makeActive log = activatePane log [] + close pane = do + (panePath,_) <- guiPropertiesFromName (paneName pane) + nb <- getNotebook panePath + mbI <- liftIO $notebookPageNum nb (getTopWidget pane) + case mbI of + Nothing -> liftIO $ do + sysMessage Normal "notebook page not found: unexpected" + return () + Just i -> do + deactivatePaneIfActive pane + liftIO $ do + notebookRemovePage nb i + widgetDestroy (getTopWidget pane) + removePaneAdmin pane + +instance RecoverablePane IDELog LogState IDEM where + saveState p = return (Just LogState) + recoverState pp LogState = do + nb <- getNotebook pp + initLog pp nb + + +------------------------------------------------------------------------------- +-- +-- * Implementation +-- + + +initLog :: PanePath -> Notebook -> IDEAction +initLog panePath nb = do + panes <- readIDE panes + paneMap <- readIDE paneMap + prefs <- readIDE prefs + (buf,cids) <- reifyIDE $ \ideR session -> 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) Nothing + widgetShowAll (scrolledWindowL buf) + cid1 <- tv `afterFocusIn` + (\_ -> do reflectIDE (makeActive buf) ideR session; return True) + cid2 <- tv `onButtonPress` + (\ b -> do reflectIDE (clicked b buf) ideR session; return True) + return (buf,[ConnectC cid1, ConnectC cid2]) + addPaneAdmin buf cids panePath + liftIO $widgetGrabFocus (textView buf) + +clicked :: Event -> IDELog -> IDEAction +clicked (Button _ SingleClick _ _ _ _ LeftButton x y) ideLog = do + errors' <- readIDE errors + line' <- liftIO $ 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 isJust succ + then markErrorInSourceBuf (line thisErr) (column thisErr) + (errDescription thisErr) + else return () + log :: IDELog <- getLog + liftIO $ markErrorInLog log (logLines thisErr) + modifyIDE_ (\ide -> return (ide{currentErr = Just n})) + otherwise -> return () +clicked (Button _ SingleClick _ _ _ _ RightButton x y) ideLog = do + errors' <- readIDE errors + line' <- reifyIDE $ \ideR session -> 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)] -> reifyIDE $ \ideR session -> do + theMenu <- menuNew + item0 <- menuItemNewWithLabel "Add all imports" + item0 `onActivateLeaf` do + reflectIDE addAllImports' ideR session + menuShellAppend theMenu item0 + case parseNotInScope (errDescription thisErr) of + Nothing -> do + return () + Just _ -> do + item1 <- menuItemNewWithLabel "Add import" + item1 `onActivateLeaf` do + reflectIDE (addImport thisErr >> return()) ideR session + menuShellAppend theMenu item1 + menuPopup theMenu Nothing + widgetShowAll theMenu + return () + otherwise -> return () +clicked _ _ = return () + +getLog' :: IDEM IDELog +getLog' = do + mbPane <- getPane + 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 + 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 + liftIO $ 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 + idleAdd (do + buf <- textViewGetBuffer tv + iter <- textBufferGetIterAtLineOffset buf (l1-1) 0 + iter2 <- textBufferGetIterAtLineOffset buf l2 0 + textBufferSelectRange buf iter iter2 + textBufferMoveMarkByName buf "end" iter + mbMark <- textBufferGetMark buf "end" + case mbMark of + Nothing -> return () + Just mark -> do + textViewScrollToMark tv mark 0.0 (Just (0.3,0.3)) + return () + return False) priorityDefaultIdle + return () + + +clearLog' :: IDEAction +clearLog' = do + log <- getLog + buf <- liftIO$ textViewGetBuffer $textView log + liftIO $textBufferSetText buf "" + modifyIDE_ (\ide -> return (ide{errors = [], currentErr = Nothing})) + +---------------------------------------------------------------------------- +-- |* Import Wizard + +-- | Add all imports which gave error messages ... +addAllImports' :: IDEAction +addAllImports' = do + errors <- readIDE errors + mapM_ addImport [ y | (x,y) <- + nubBy (\ (p1,_) (p2,_) -> p1 == p2) + $ [(x,y) | (x,y) <- [((parseNotInScope . errDescription) e, e) | e <- errors]], + isJust x] + +-- | Add import for current error ... +addOneImport' :: IDEAction +addOneImport' = do + errors' <- readIDE errors + currentErr' <- readIDE currentErr + case currentErr' of + Nothing -> do + ideMessage Normal $ "No error selected" + return () + Just i -> do + if 0 <= i && i < length errors' + then let error = errors' !! i + in addImport error >> return () + else error "Log>>addOneImport: Error out of range" + +-- | Add one missing import +addImport :: ErrorSpec -> IDEM (Bool,Maybe ModuleName) +addImport error = + case parseNotInScope (errDescription error) of + Nothing -> trace "Dont parse as not in scope error" return (True,Nothing) + Just nis -> do + currentInfo' <- readIDE currentInfo + case currentInfo' of + Nothing -> trace "No current info" return (False,Nothing) + Just ((_,symbolTable1),(_,symbolTable2)) -> + case (getIdentifierDescr (id' nis) symbolTable1 symbolTable2) of + [] -> do + ideMessage Normal $ "Identifier " ++ (id' nis) ++ + " not found in imported packages" + return (True,Nothing) + descr : [] -> addImport' nis (filePath error) descr + list -> do + mbDescr <- liftIO $ selectModuleDialog list (id' nis) + case mbDescr of + Nothing -> return (False,Nothing) + Just descr -> addImport' nis (filePath error) descr + +addImport' :: NotInScopeParseResult -> FilePath -> Descr -> IDEM (Bool,Maybe ModuleName) +addImport' nis filePath descr = let + mbQ = mbQual' nis + id = id' nis + mod = case descr of + Descr _ _ m _ _ _ -> modu m + Reexported m _ -> modu m + importId = if isSub' nis + then ImportCoC (getRealId descr id) Nothing + else if isOp' nis + then ImportOp (id' nis) + else ImportId (id' nis) + importSpec = ImportSpec (render $disp mod) mbQ (Just ([importId],True)) 0 + in do + candy' <- readIDE candy + mbBuf <- selectSourceBuf filePath + case mbBuf of + Nothing -> return (True,Nothing) + Just buf -> do + inBufContext' () $ \ _ gtkbuf _ _ -> do + ideMessage Normal $ "addImport " ++ show id ++ " from " ++ (render $ disp $ mod) + liftIO $ do + i1 <- textBufferGetStartIter gtkbuf + i2 <- textBufferGetEndIter gtkbuf + text <- getCandylessText candy' gtkbuf + let (importSpecs,lastImport) = getImportSpecs text + linesToModify = filter (\ is -> modid is == (render $ disp $ mod) + && mbQual is == mbQ + && not(isHiding (mbImpspec is))) importSpecs + case linesToModify of + [] -> let newSpec = importSpec + newLine = show newSpec ++ "\n" + lineSel = let bv = foldl' max 0 (map lineNr importSpecs) in + if bv == 0 + then (lastImport `max` 0) + else bv + in do + textIterSetLine i1 lineSel + textBufferInsert gtkbuf i1 newLine + (spec:t) -> let newSpec = spec{mbImpspec = + case mbImpspec spec of + Nothing -> Just ([importId],True) + Just (ids,b) -> Just (nub(importId:ids),b)} + newLine = show newSpec ++ "\n" + in do + textIterSetLine i1 (lineNr spec - 1) + textIterSetLine i2 (lineNr spec) + textBufferDelete gtkbuf i1 i2 + textBufferInsert gtkbuf i1 newLine + return (True,Just mod) + where + isHiding (Just (_,False)) = True + isHiding _ = False + +getRealId descr id = if isReexported descr + then getRealId (impDescr descr) id + else getReal (details' descr) + where + getReal (FieldDescr d) = descrName' d + getReal (ConstructorDescr d) = descrName' d + getReal (MethodDescr d) = descrName' d + getReal _ = id + +-- |* The import data + +data NotInScopeParseResult = NotInScopeParseResult { + mbQual' :: Maybe String + , id' :: String + , isSub' :: Bool + , isOp' :: Bool} + deriving Eq + +data ImportSpec = ImportSpec + { modid :: String + , mbQual :: Maybe String + , mbImpspec :: Maybe ([ImportItem],Bool) + , lineNr :: Int} + +data ImportItem = + ImportId String + | ImportOp String + | ImportCoC String (Maybe [ImportSubItem]) + deriving Eq + +instance Show ImportItem where + show (ImportId str) = str + show (ImportOp str) = "(" ++ str ++ ")" + show (ImportCoC str Nothing) = str ++ "(..)" + show (ImportCoC str (Just [])) = str + show (ImportCoC str (Just l)) = str ++ "(" ++ showCoC l + where + showCoC [a] = show a ++ ")" + showCoC (a:b) = show a ++ "," ++ showCoC b + showCoC _ = error "Log>>instance ImportItem Show: Empty list" + + +data ImportSubItem = + ImportSubId String + | ImportSubOp String + deriving Eq + +instance Show ImportSubItem where + show (ImportSubId str) = str + show (ImportSubOp str) = "(" ++ str ++ ")" + +instance Show ImportSpec where + show (ImportSpec modid mbQual mbImpspec _) = "import " + ++ case mbQual of + Nothing -> "" + Just _ -> "qualified " + ++ modid + ++ case mbQual of + Nothing -> "" + Just str -> " as " ++ str ++ " " + ++ case mbImpspec of + Nothing -> "" + Just ([],True) -> "" + Just (l,True) -> " (" ++ showImportSpecs l + Just (l, False) -> " hiding (" ++ showImportSpecs l + where + showImportSpecs [a] = show a ++ ")" + showImportSpecs (a:b) = show a ++ "," ++ showImportSpecs b + showImportSpecs _ = error "Log>>showImportSpecs: Empty list" + + +-- |* The error line parser + +lexer = P.makeTokenParser haskellStyle +lexeme = P.lexeme lexer +whiteSpace = P.whiteSpace lexer +symbol = P.symbol lexer +identifier = P.identifier lexer +comma = P.comma lexer +dot = P.dot lexer +integer = P.integer lexer +parens = P.parens lexer +operator = P.operator lexer + +parseNotInScope :: String -> (Maybe NotInScopeParseResult) +parseNotInScope str = + case parse scopeParser "" str of + Left e -> Nothing + Right r -> Just r + +scopeParser :: CharParser () NotInScopeParseResult +scopeParser = do + whiteSpace + symbol "Not in scope:" + isSub <- optionMaybe (try (choice [symbol "type constructor or class" + , symbol "data constructor"])) + symbol "`" + mbQual <- optionMaybe (try (do + q <- lexeme conid + dot + return q)) + id <- optionMaybe (try identifier) + case id of + Just id -> return (NotInScopeParseResult mbQual + (take (length id - 1) id) (isJust isSub) False) + Nothing -> do + op <- operator + symbol "'" + return (NotInScopeParseResult mbQual op (isJust isSub) True) + "scopeParser" + +-- |* The import parser + +getImportSpecs :: String -> ([ImportSpec],Int) +getImportSpecs modSource = + case parse importSpecParser "" modSource of + Left e -> trace ("parse failed with " ++ show e) ([],0) + Right specs -> trace (show specs) specs + +importSpecParser :: CharParser () ([ImportSpec],Int) +importSpecParser = do + whiteSpace + skipHeader + lines <- sepBy (try parseImportLine) (many newline) + pos <- getPosition + skipMany anyChar + eof + return (lines, sourceLine pos - 2) + "importSpecParser" + +skipHeader :: CharParser () () +skipHeader =do + try (do + symbol "module" + manyTill anyChar (try (symbol "where")) + trace "with module header " (return ())) + <|> trace "no module header " (return ()) + "skipHeader" + +parseImportLine :: CharParser () ImportSpec +parseImportLine = do + symbol "import" + pos <- getPosition + isQualified <- optionMaybe (try (symbol "qualified")) + modid <- lexeme mident + whiteSpace + mbQName <- if isJust isQualified + then do + symbol "as" + qid <- identifier + return (Just qid) + else return Nothing + mbImpSpec <- optionMaybe + (try (do + mbHiding <- optionMaybe (try (symbol "hiding")) + idList <- parens (sepBy parseImportItem comma) + return (idList, isNothing mbHiding))) + whiteSpace + return (ImportSpec modid mbQName mbImpSpec (sourceLine pos)) + "parseImportLine" + +parseImportItem :: CharParser () ImportItem +parseImportItem = do + id <- optionMaybe (try identifier) + case id of + Just id -> if isUpper (head id) + then do + ccList <- optionMaybe (try parseSubList) + return (ImportCoC id Nothing) + else return (ImportId id) + Nothing -> do + op <- optionMaybe (try (parens operator)) + case op of + Just op -> return (ImportOp op) + Nothing -> do + pos <- getPosition + error $ "Can't parse import item " ++ show pos + "parseImportItem" + +parseSubList :: CharParser () (Maybe [ImportSubItem]) +parseSubList = do + all <- optionMaybe (try (symbol "(..)")) + case all of + Just _ -> return Nothing + Nothing -> do + list <- optionMaybe (try (parens (sepBy parseSubItem comma))) + case list of + Nothing -> return (Just []) + Just l -> return list + "parseSubList" + +parseSubItem :: CharParser () ImportSubItem +parseSubItem = do + id <- optionMaybe (try identifier) + case id of + Just id -> return (ImportSubId id) + Nothing -> do + op <- optionMaybe (try operator) + case op of + Just op -> return (ImportSubOp op) + Nothing -> do + pos <- getPosition + error $ "Can't parse sub import item " ++ show pos + "parseSubItem" + +mident = do + c <- P.identStart haskellDef + cs <- many (alphaNum <|> oneOf "_'.") + return (c:cs) + "midentifier" + +conid = do + c <- upper + cs <- many (alphaNum <|> oneOf "_'") + return (c:cs) + "conid" + +-- |* The stupid little dialog + +moduleFields :: [String] -> String -> FieldDescription String +moduleFields list id = + mkField + (paraName <<<- ParaName ("From which module is " ++ id) + $ paraMultiSel <<<- ParaMultiSel False + $ emptyParams) + (\ a -> [a]) + (\ [a] b -> a) + (staticListEditor ((nub . sort) list)) + +selectModuleDialog :: [Descr] -> String -> IO (Maybe Descr) +selectModuleDialog list id = do + dia <- dialogNew + upper <- dialogGetUpper dia + lower <- dialogGetActionArea dia + (widget,_,ext,_) <- buildEditor (moduleFields + (map (render . disp . modu . descrModu') list) id) + ((render . disp . modu . descrModu') (head list)) + (widget2,_,_,notifier) <- buildEditor okCancelFields () + registerEvent notifier Clicked (Left (\e -> do + case eventPaneName e of + "Ok" -> dialogResponse dia ResponseOk + _ -> dialogResponse dia ResponseCancel + return e)) + boxPackStart upper widget PackGrow 7 + boxPackStart lower widget2 PackNatural 7 + widgetShowAll dia + resp <- dialogRun dia + value <- ext ([]) + widgetDestroy dia + --find + case (resp,value) of + (ResponseOk,Just v) -> return (Just (head (filter (\e -> (render . disp . modu . descrModu') e == v) + list))) + _ -> trace ("cancel") return Nothing + +-- --------------------------------------------------------------------- +-- ** Spawning external processes +-- + +readOut :: IDELog -> Handle -> IO () +readOut log hndl = + catch (readAndShow) + (\(e :: SomeException) -> 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 :: SomeException) -> do + hClose hndl + return ()) + where + readAndShow = do + line <- hGetLine hndl + appendLog log (line ++ "\n") ErrorTag + readAndShow + +runExternal :: FilePath -> [String] -> IO (Handle, Handle, Handle, ProcessHandle) +runExternal path args = do + putStrLn $ "Run external called with args " ++ show args + hndls@(inp, out, err, _) <- runInteractiveProcess path args Nothing Nothing + sysMessage Normal $ "Starting external tool: " ++ path ++ " with args " ++ (show args) + hSetBuffering out NoBuffering + hSetBuffering err NoBuffering + hSetBuffering inp NoBuffering + hSetBinaryMode out True + hSetBinaryMode err True + return hndls + diff --git a/src/IDE/Pane/Modules.hs b/src/IDE/Pane/Modules.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Pane/Modules.hs @@ -0,0 +1,1094 @@ +{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses + -XScopedTypeVariables -XTypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Pane.Modules +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | The pane of ide where modules are presented in tree form with their +-- packages and exports +-- +------------------------------------------------------------------------------- + +module IDE.Pane.Modules ( + IDEModules(..) +, ModulesState(..) + +, showModules +, showInterface +, selectIdentifier +, reloadKeepSelection +, replaySelHistory +, replayScopeHistory +) where + +import Graphics.UI.Gtk hiding (get) +import qualified Graphics.UI.Gtk.ModelView as New +import Graphics.UI.Gtk.Gdk.Events +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 Prelude hiding (catch) +import Data.IORef +import IDE.Core.State +import IDE.Pane.Info +import IDE.Pane.SourceBuffer +import Control.Event hiding (Event) +import Distribution.ModuleName +import Distribution.Text (simpleParse,display) +import Data.Typeable (Typeable(..)) +import Control.Exception (SomeException(..),catch) +import IDE.Package (packageConfig,addModuleToPackageDescr,getModuleTemplate,getPackageDescriptionAndPath) +import Distribution.PackageDescription (allBuildInfo,hsSourceDirs) +import System.FilePath ((),dropFileName) +import System.Directory (doesFileExist,createDirectoryIfMissing) +import Graphics.UI.Editor.MakeEditor (buildEditor,FieldDescription(..),mkField) +import Graphics.UI.Editor.Parameters (paraMultiSel,Parameter(..),emptyParams,(<<<-),paraName) +import Graphics.UI.Editor.Simple (boolEditor,okCancelFields,staticListEditor,stringEditor) +import Graphics.UI.Editor.Basics (eventPaneName,GUIEventSelector(..)) +import MyMissing (forceJust,forceHead,split) +import IDE.Metainfo.Provider (rebuildActiveInfo) +import Debug.Trace (trace) + + +-- | A modules pane description +-- + +data IDEModules = IDEModules { + outer :: VBox +, paned :: HPaned +, treeView :: New.TreeView +, treeStore :: New.TreeStore (String, [(ModuleDescr,PackageDescr)]) +, descrView :: New.TreeView +, descrStore :: New.TreeStore Descr +, localScopeB :: RadioButton +, packageScopeB :: RadioButton +, worldScopeB :: RadioButton +, blacklistB :: CheckButton +, oldSelection :: IORef SelectionState +} deriving Typeable + + +data ModulesState = ModulesState Int (Scope,Bool) + (Maybe ModuleName, Maybe Symbol) + deriving(Eq,Ord,Read,Show,Typeable) + + +instance IDEObject IDEModules + +instance Pane IDEModules IDEM + where + primPaneName _ = "Modules" + getAddedIndex _ = 0 + getTopWidget = castToWidget . outer + paneId b = "*Modules" + makeActive p = do + activatePane p [] + --liftIO $ widgetGrabFocus (descrView p) + close pane = do + (panePath,_) <- guiPropertiesFromName (paneName pane) + nb <- getNotebook panePath + mbI <- liftIO $notebookPageNum nb (getTopWidget pane) + case mbI of + Nothing -> throwIDE "Pane>IDEModules: notebook page not found: unexpected" + Just i -> do + deactivatePaneIfActive pane + liftIO $ do + notebookRemovePage nb i + widgetDestroy (getTopWidget pane) + removePaneAdmin pane + +instance RecoverablePane IDEModules ModulesState IDEM where + saveState p = do + (IDEModules _ _ treeView treeStore descrView descrStore _ _ _ _ _) <- getModules + sc <- getScope + mbModules <- getPane + case mbModules of + Nothing -> return Nothing + Just p -> liftIO $ do + i <- panedGetPosition (paned p) + mbTreeSelection <- getSelectionTree treeView treeStore + mbFacetSelection <- getSelectionDescr descrView descrStore + let mbs = (case mbTreeSelection of + Nothing -> Nothing + Just (_,[]) -> Nothing + Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md), + case mbFacetSelection of + Nothing -> Nothing + Just fw -> Just (descrName fw)) + return (Just (ModulesState i sc mbs)) + recoverState pp (ModulesState i sc@(scope,useBlacklist) se) = do + nb <- getNotebook pp + initModules pp nb + mod@(IDEModules _ _ treeView treeStore descrView descrStore lb pb wb blb _) + <- getModules + case scope of + Local -> liftIO $ toggleButtonSetActive lb True + Package -> liftIO $ toggleButtonSetActive pb True + System -> liftIO $ toggleButtonSetActive wb True + liftIO $ toggleButtonSetActive blb useBlacklist + liftIO $ panedSetPosition (paned mod) i + fillModulesList sc + selectNames se + + + +selectIdentifier :: Descr -> IDEAction +selectIdentifier idDescr = do + accessibleInfo' <- readIDE accessibleInfo + currentInfo' <- readIDE currentInfo + currentScope <- getScope + let pid = pack (descrModu idDescr) + let mbNeededScope = case currentInfo' of + Just (localScope,packageScope) -> + if Map.member pid (fst localScope) + then Just Local + else if Map.member pid (fst packageScope) + then Just Package + else case accessibleInfo' of + Just worldScope -> + if Map.member pid (fst worldScope) + then Just System + else Nothing + Nothing -> Nothing + Nothing -> case accessibleInfo' of + Just worldScope -> + if Map.member pid (fst worldScope) + then Just System + else Nothing + Nothing -> Nothing + case mbNeededScope of + Nothing -> return () + Just sc -> do + when (fst currentScope < sc) (setScope (sc,snd currentScope)) + selectIdentifier' (modu $ descrModu idDescr) (descrName idDescr) + +selectIdentifier' :: ModuleName -> Symbol -> IDEAction +selectIdentifier' moduleName symbol = + let nameArray = components moduleName + in do + mods@(IDEModules _ _ treeView treeStore descrView descrStore _ _ _ _ _) <- getModules + mbTree <- liftIO $ treeStoreGetTreeSave treeStore [] + case treePathFromNameArray mbTree nameArray [] of + Just treePath -> liftIO $ 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)) + mbFacetTree <- treeStoreGetTreeSave descrStore [] + selF <- New.treeViewGetSelection descrView + case findPathFor symbol mbFacetTree of + Nothing -> sysMessage Normal "no path found" + Just path -> do + New.treeViewExpandToPath descrView path + New.treeSelectionSelectPath selF path + col <- New.treeViewGetColumn descrView 0 + New.treeViewScrollToCell descrView path (fromJust col) (Just (0.3,0.3)) + bringPaneToFront mods + Nothing -> return () + +findPathFor :: Symbol -> Maybe (Tree Descr) -> Maybe TreePath +findPathFor symbol (Just (Node _ forest)) = + foldr ( \i mbTreePath -> findPathFor' [i] (forest !! i) mbTreePath) + Nothing [0 .. ((length forest) - 1)] + where + findPathFor' :: TreePath -> Tree Descr -> Maybe TreePath -> Maybe TreePath + findPathFor' _ node (Just p) = Just p + findPathFor' path (Node wrap sub) Nothing = + if descrName wrap == symbol + then Just (reverse path) + else + foldr ( \i mbTreePath -> findPathFor' (i:path) (sub !! i) mbTreePath) + Nothing [0 .. ((length sub) - 1)] +findPathFor symbol Nothing = Nothing + +treePathFromNameArray :: Maybe ModTree -> [String] -> [Int] -> Maybe [Int] +treePathFromNameArray (Just tree) [] accu = Just (reverse accu) +treePathFromNameArray (Just 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 (Just (subForest tree !! i)) t (i:accu) +treePathFromNameArray Nothing _ _ = Nothing + +showModules :: IDEAction +showModules = do + m <- getModules + liftIO $ bringPaneToFront m + liftIO $ widgetGrabFocus (treeView m) + +showInterface :: IDEAction +showInterface = do + m <- getModules + liftIO $ bringPaneToFront m + liftIO $ widgetGrabFocus (descrView m) + +getModules :: IDEM IDEModules +getModules = do + mbMod <- getPane + 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 + 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 + panes <- readIDE panes + paneMap <- readIDE paneMap + prefs <- readIDE prefs + currentInfo <- readIDE currentInfo + (buf,cids) <- reifyIDE $ \ideR session -> 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.treeViewSetRulesHint treeView True + + renderer0 <- New.cellRendererPixbufNew + set renderer0 [ New.cellPixbufStockId := "" ] + + renderer <- New.cellRendererTextNew + col <- New.treeViewColumnNew + New.treeViewColumnSetTitle col "Modules" + New.treeViewColumnSetSizing col TreeViewColumnAutosize + New.treeViewColumnSetResizable col True + 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 -> [ + New.cellPixbufStockId := + if null (snd row) + then "" + else if isJust (mbSourcePathMD (fst (head (snd row)))) + then "ide_source" + else ""] + + renderer2 <- New.cellRendererTextNew + col2 <- New.treeViewColumnNew + New.treeViewColumnSetTitle col2 "Packages" + New.treeViewColumnSetSizing col2 TreeViewColumnAutosize + New.treeViewColumnSetResizable col2 True + New.treeViewColumnSetReorderable col2 True + New.treeViewAppendColumn treeView col2 + New.cellLayoutPackStart col2 renderer2 True + New.cellLayoutSetAttributes col2 renderer2 treeStore + $ \row -> [ New.cellText := (concat . intersperse ", ") + $ map (display . packagePD . snd) (snd row)] + New.treeViewSetHeadersVisible treeView True + New.treeViewSetEnableSearch treeView True + New.treeViewSetSearchEqualFunc treeView (Just (treeViewSearch treeView treeStore)) + +-- Facet view + + descrView <- New.treeViewNew + descrStore <- New.treeStoreNew [] + New.treeViewSetModel descrView descrStore + renderer30 <- New.cellRendererPixbufNew + renderer31 <- New.cellRendererPixbufNew + renderer3 <- New.cellRendererTextNew + col <- New.treeViewColumnNew + New.treeViewColumnSetTitle col "Interface" + --New.treeViewColumnSetSizing col TreeViewColumnAutosize + New.treeViewAppendColumn descrView col + New.cellLayoutPackStart col renderer30 False + New.cellLayoutPackStart col renderer31 False + New.cellLayoutPackStart col renderer3 True + New.cellLayoutSetAttributes col renderer3 descrStore + $ \row -> [ New.cellText := descrTreeText row] + New.cellLayoutSetAttributes col renderer30 descrStore + $ \row -> [ + New.cellPixbufStockId := stockIdFromType (descrIdType row)] + New.cellLayoutSetAttributes col renderer31 descrStore + $ \row -> [ + New.cellPixbufStockId := if isReexported row + then "ide_reexported" + else if isJust (mbLocation row) + then "ide_source" + else ""] + New.treeViewSetHeadersVisible descrView True + New.treeViewSetEnableSearch descrView True + New.treeViewSetSearchEqualFunc descrView (Just (descrViewSearch descrView descrStore)) + pane' <- hPanedNew + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw treeView + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + sw2 <- scrolledWindowNew Nothing Nothing + containerAdd sw2 descrView + 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 "System" + toggleButtonSetActive rb3 True + 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 + oldState <- liftIO $ newIORef $ SelectionState Nothing Nothing System False + scopeRef <- newIORef (System,True) + let modules = IDEModules boxOuter pane' treeView treeStore descrView descrStore + rb1 rb2 rb3 cb oldState + notebookInsertOrdered nb boxOuter (paneName modules) Nothing + widgetShowAll boxOuter + cid3 <- treeView `New.onRowActivated` + (\ treePath _ -> do + New.treeViewExpandRow treeView treePath False + return ()) + cid1 <- treeView `afterFocusIn` + (\_ -> do reflectIDE (makeActive modules) ideR session; return True) + cid2 <- descrView `afterFocusIn` + (\_ -> do reflectIDE (makeActive modules) ideR session; return True) + treeView `onButtonPress` (treeViewPopup ideR session treeStore treeView) + descrView `onButtonPress` (descrViewPopup ideR session descrStore descrView) + rb1 `onToggled` (reflectIDE scopeSelection ideR session) + rb2 `onToggled` (reflectIDE scopeSelection ideR session) + rb3 `onToggled` (reflectIDE scopeSelection ideR session) + cb `onToggled` (reflectIDE scopeSelection ideR session) + sel <- New.treeViewGetSelection treeView + sel `New.onSelectionChanged` do + fillFacets treeView treeStore descrView descrStore + reflectIDE recordSelHistory ideR session + return () + sel2 <- New.treeViewGetSelection descrView + sel2 `New.onSelectionChanged` do + fillInfo descrView descrStore ideR session + reflectIDE recordSelHistory ideR session + return () + return (modules,[ConnectC cid1,ConnectC cid2, ConnectC cid3]) + addPaneAdmin buf cids panePath + liftIO $widgetGrabFocus (paned buf) + +treeViewSearch :: TreeView + -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) + -> String + -> New.TreeIter + -> IO Bool +treeViewSearch treeView treeStore string iter = do + path <- New.treeModelGetPath treeStore iter + val <- New.treeStoreGetValue treeStore path + mbTree <- treeStoreGetTreeSave treeStore path + exp <- New.treeViewRowExpanded treeView path + when (isJust mbTree && (not (null (subForest (fromJust mbTree)))) && not exp) $ + let found = searchInModSubnodes (fromJust mbTree) string + in when found $ do + New.treeViewExpandRow treeView path False + return () + let str2 = case snd val of + [] -> fst val + (m,_):_ -> showPackModule (moduleIdMD m) + let res = isInfixOf (map toLower string) (map toLower str2) + return res + +searchInModSubnodes :: ModTree -> String -> Bool +searchInModSubnodes 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) + +descrViewSearch :: TreeView + -> New.TreeStore Descr + -> String + -> New.TreeIter + -> IO Bool +descrViewSearch descrView descrStore string iter = do + path <- New.treeModelGetPath descrStore iter + val <- New.treeStoreGetValue descrStore path + tree <- New.treeStoreGetTree descrStore path + exp <- New.treeViewRowExpanded descrView path + when (not (null (subForest tree)) && not exp) $ + let found = searchInFacetSubnodes tree string + in when found $ do + New.treeViewExpandRow descrView path False + return () + return (isInfixOf (map toLower string) (map toLower (descrTreeText val))) + +searchInFacetSubnodes :: DescrTree -> String -> Bool +searchInFacetSubnodes tree str = + not $ null + $ filter (\ val -> + isInfixOf (map toLower str) (map toLower (descrTreeText val))) + $ concatMap flatten (subForest tree) + +fillFacets :: New.TreeView + -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) + -> New.TreeView + -> New.TreeStore Descr + -> IO () +fillFacets treeView treeStore descrView descrStore = do + sel <- getSelectionTree treeView treeStore + case sel of + Just val + -> case snd val of + ((mod,package):_) + -> let forest = buildFacetForrest mod in do + emptyModel <- New.treeStoreNew [] + New.treeViewSetModel descrView emptyModel + New.treeStoreClear descrStore + mapM_ (\(e,i) -> New.treeStoreInsertTree descrStore [] i e) + $ zip forest [0 .. length forest] + New.treeViewSetModel descrView descrStore + New.treeViewSetEnableSearch descrView True + New.treeViewSetSearchEqualFunc descrView (Just (descrViewSearch descrView descrStore)) + [] -> New.treeStoreClear descrStore + Nothing + -> New.treeStoreClear descrStore + +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) + +getSelectionDescr :: New.TreeView + -> New.TreeStore Descr + -> IO (Maybe Descr) +getSelectionDescr 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 Descr + -> IDERef + -> Session + -> IO () +fillInfo treeView lst ideR session = do + treeSelection <- New.treeViewGetSelection treeView + paths <- New.treeSelectionGetSelectedRows treeSelection + case paths of + [] -> return () + [a] -> do + descr <- New.treeStoreGetValue lst a + reflectIDE (setInfo descr) ideR session + return () + _ -> return () + +findDescription :: PackModule -> SymbolTable -> Symbol -> Maybe (Symbol,Descr) +findDescription md st s = + case Map.lookup s st of + Nothing -> Nothing + Just l -> case filter (\id -> md == descrModu 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 + (System,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 liftIO $ do + New.treeStoreClear treeStore + mapM_ (\(e,i) -> New.treeStoreInsertTree treeStore [] i e) + $ zip li [0 .. length li] + _ -> liftIO $ do + New.treeStoreClear treeStore + New.treeStoreInsertTree treeStore [] 0 (Node ("",[]) []) + Just (l,p) -> let (l',p'@(pm,ps)) = case scope of + Local -> (l,(Map.empty,Map.empty)) + Package -> (l,p) + System -> 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 liftIO $ 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.treeViewSetEnableSearch treeView True + New.treeViewSetSearchEqualFunc treeView (Just (treeViewSearch treeView treeStore)) + + +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 DescrForest = Forest Descr +type DescrTree = Tree Descr + + +descrTreeText :: Descr -> String +descrTreeText (Descr id _ _ _ _ (InstanceDescr binds)) = id ++ " " ++ printBinds binds + where + printBinds [] = "" + printBinds (a:[]) = a + printBinds (a:b) = a ++ " " ++ printBinds b +descrTreeText d = descrName d + +descrIdType :: Descr -> DescrType +descrIdType = descrType . details + +buildFacetForrest :: ModuleDescr -> DescrForest +buildFacetForrest modDescr = + let (instances,other) = partition (\id -> case details id of + InstanceDescr _ -> True + _ -> False) + $ idDescriptionsMD modDescr + forestWithoutInstances = map buildFacet other + (forest2,orphaned) = foldl' addInstances (forestWithoutInstances,[]) + instances + orphanedNodes = map (\ inst -> Node inst []) orphaned + in forest2 ++ reverse orphanedNodes + where + -- expand nodes in a module desciption for the description tree + buildFacet :: Descr -> DescrTree + buildFacet descr = + case details descr of + DataDescr constructors fields -> + Node descr ((map (\(fn,ty) -> Node (makeReexported descr (Descr{descrName' = fn, typeInfo' = ty, + descrModu' = descrModu descr, mbLocation' = mbLocation descr, + mbComment' = mbComment descr, details' = ConstructorDescr {typeDescrC = descr}})) []) + constructors) + ++ (map (\(fn,ty) -> Node (makeReexported descr (Descr{descrName' = fn, typeInfo' = ty, + descrModu' = descrModu descr, mbLocation' = mbLocation descr, + mbComment' = mbComment descr, details' = FieldDescr {typeDescrF = descr}})) []) + fields)) + NewtypeDescr constr mbField -> + Node descr (Node (makeReexported descr (Descr{descrName' = fst constr, typeInfo' = snd constr, + descrModu' = descrModu descr, mbLocation' = mbLocation descr, + mbComment' = mbComment descr, details' = ConstructorDescr {typeDescrC = descr}})) [] + : case mbField of + Just fld -> + [Node (makeReexported descr (Descr{descrName' = fst fld, typeInfo' = snd fld, + descrModu' = descrModu descr, mbLocation' = mbLocation descr, + mbComment' = mbComment descr, details' = FieldDescr {typeDescrF = descr}})) []] + Nothing -> []) + ClassDescr _ methods -> + Node descr (map (\(fn,ty) -> Node (makeReexported descr (Descr{descrName' = fn, typeInfo' = ty, + descrModu' = descrModu descr, mbLocation' = mbLocation descr, + mbComment' = mbComment descr, details' = MethodDescr {classDescrM = descr}})) []) + methods) + _ -> Node descr [] + where + makeReexported :: Descr -> Descr -> Descr + makeReexported d1 d2 + | isReexported d1 = Reexported{descrModu' = descrModu' d1, impDescr = d2} + | otherwise = d2 + + addInstances :: (DescrForest,[Descr]) + -> Descr + -> (DescrForest,[Descr]) + addInstances (forest,orphaned) instDescr = + case foldl' (matches instDescr) ([],False) forest of + (f,True) -> (f,orphaned) + (f,False) -> (forest, instDescr:orphaned) + + matches :: Descr + -> (DescrForest,Bool) + -> DescrTree + -> (DescrForest,Bool) + matches instDescr (forest,False) (Node dd@(Descr id _ _ _ _ (DataDescr _ _)) sub) + | not (null (binds (details instDescr))) && + id == head (binds (details instDescr)) + = ((Node dd (sub ++ [Node newInstDescr []])):forest,True) + where newInstDescr = if isNothing (mbLocation instDescr) + then instDescr{mbLocation' = mbLocation dd} + else instDescr + matches instDescr (forest,False) (Node dd@(Descr id _ _ _ _ (NewtypeDescr _ _)) sub) + | not (null (binds (details instDescr))) && + id == head (binds (details instDescr)) + = ((Node dd (sub ++ [Node newInstDescr []])):forest,True) + where newInstDescr = if isNothing (mbLocation instDescr) + then instDescr{mbLocation' = mbLocation dd} + else instDescr + 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 = components $ 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 + -> Session + -> New.TreeStore (String, [(ModuleDescr,PackageDescr)]) + -> New.TreeView + -> Event + -> IO (Bool) +treeViewPopup ideR session store treeView (Button _ click _ _ _ _ button _ _) = do + if button == RightButton + then do + theMenu <- menuNew + item1 <- menuItemNewWithLabel "Edit source" + item1 `onActivateLeaf` do + sel <- getSelectionTree treeView store + case sel of + Just (_,[(m,_)]) -> case mbSourcePathMD m of + Nothing -> return () + Just fp -> do + reflectIDE (selectSourceBuf fp) ideR session + return () + otherwise -> return () + sep1 <- separatorMenuItemNew + item2 <- menuItemNewWithLabel "Expand here" + item2 `onActivateLeaf` (expandHere treeView) + item3 <- menuItemNewWithLabel "Collapse here" + item3 `onActivateLeaf` (collapseHere treeView) + item4 <- menuItemNewWithLabel "Expand all" + item4 `onActivateLeaf` (New.treeViewExpandAll treeView) + item5 <- menuItemNewWithLabel "Collapse all" + item5 `onActivateLeaf` (New.treeViewCollapseAll treeView) + sep2 <- separatorMenuItemNew + item6 <- menuItemNewWithLabel "Add module" + item6 `onActivateLeaf` (reflectIDE (addModule treeView store) ideR session) + + mapM_ (menuShellAppend theMenu) [castToMenuItem item1, castToMenuItem sep1, castToMenuItem item2, + castToMenuItem item3, castToMenuItem item4, castToMenuItem item5, castToMenuItem sep2, + castToMenuItem item6{--,item7,item8--}] + 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 + reflectIDE (selectSourceBuf fp) ideR session + return () + otherwise -> return () + return True + else return False +treeViewPopup _ _ _ _ _ = throwIDE "treeViewPopup wrong event type" + +descrViewPopup :: IDERef + -> Session + -> New.TreeStore Descr + -> New.TreeView + -> Event + -> IO (Bool) +descrViewPopup ideR session store descrView (Button _ click _ _ _ _ button _ _) = do + if button == RightButton + then do + theMenu <- menuNew + item1 <- menuItemNewWithLabel "Go to definition" + item1 `onActivateLeaf` do + sel <- getSelectionDescr descrView store + case sel of + Just descr -> reflectIDE + (goToDefinition descr) ideR session + otherwise -> sysMessage Normal "no selection" + menuShellAppend theMenu item1 + menuPopup theMenu Nothing + widgetShowAll theMenu + return True + else if button == LeftButton && click == DoubleClick + then do sel <- getSelectionDescr descrView store + case sel of + Just descr -> reflectIDE (goToDefinition descr) ideR session + otherwise -> sysMessage Normal "no selection" + return True + else do + mbPane :: Maybe IDEInfo <- reflectIDE getPane ideR session + when (isJust mbPane) $ bringPaneToFront (fromJust mbPane) + return False + +descrViewPopup _ _ _ _ _ = throwIDE "descrViewPopup wrong event type" + +setScope :: (Scope,Bool) -> IDEAction +setScope (sc,bl) = do + (IDEModules _ _ treeView treeStore descrView descrStore localScopeB + packageScopeB worldScopeB blacklistB _) <- getModules + case sc of + Local -> liftIO $ toggleButtonSetActive localScopeB True + Package -> liftIO $ toggleButtonSetActive packageScopeB True + System -> liftIO $ toggleButtonSetActive worldScopeB True + liftIO $ toggleButtonSetActive blacklistB bl + selectScope (sc,bl) + +getScope :: IDEM (Scope,Bool) +getScope = do + (IDEModules _ _ treeView treeStore descrView descrStore localScopeB + packageScopeB worldScopeB blacklistB _) <- getModules + rb1s <- liftIO $ toggleButtonGetActive localScopeB + rb2s <- liftIO $ toggleButtonGetActive packageScopeB + rb3s <- liftIO $ toggleButtonGetActive worldScopeB + cbs <- liftIO $ toggleButtonGetActive blacklistB + let scope = if rb1s + then Local + else if rb2s + then Package + else System + return (scope,cbs) + +scopeSelection :: IDEAction +scopeSelection = do + (sc,bl) <- getScope + selectScope (sc,bl) + +selectScope :: (Scope,Bool) -> IDEAction +selectScope (sc,bl) = do + mods@(IDEModules _ _ treeView treeStore descrView descrStore _ _ _ _ _) + <- getModules + mbTreeSelection <- liftIO $ getSelectionTree treeView treeStore + mbDescrSelection <- liftIO $ getSelectionDescr descrView descrStore + + ts <- liftIO $ New.treeViewGetSelection treeView + withoutRecordingDo $ do + liftIO $ New.treeSelectionUnselectAll ts + fillModulesList (sc,bl) + let mbs = (case mbTreeSelection of + Nothing -> Nothing + Just (_,[]) -> Nothing + Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md), + case mbDescrSelection of + Nothing -> Nothing + Just fw -> Just (descrName fw)) + selectNames mbs + recordScopeHistory + liftIO $ bringPaneToFront mods + +selectNames :: (Maybe ModuleName, Maybe Symbol) -> IDEAction +selectNames (mbModuleName, mbIdName) = do + (IDEModules _ _ treeView treeStore descrView descrStore _ _ _ _ _) + <- getModules + case mbModuleName of + Nothing -> liftIO $ do + sel <- New.treeViewGetSelection treeView + New.treeSelectionUnselectAll sel + selF <- New.treeViewGetSelection descrView + New.treeSelectionUnselectAll selF + Just moduleName -> + let nameArray = components moduleName + in do + mbTree <- liftIO $ treeStoreGetTreeSave treeStore [] + case treePathFromNameArray mbTree nameArray [] of + Nothing -> return () + Just treePath -> liftIO $ 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 -> do + selF <- New.treeViewGetSelection descrView + New.treeSelectionUnselectAll selF + Just symbol -> do + mbDescrTree <- treeStoreGetTreeSave descrStore [] + selF <- New.treeViewGetSelection descrView + case findPathFor symbol mbDescrTree of + Nothing -> sysMessage Normal "no path found" + Just path -> do + New.treeSelectionSelectPath selF path + col <- New.treeViewGetColumn descrView 0 + New.treeViewScrollToCell descrView path (fromJust col) + (Just (0.3,0.3)) + +reloadKeepSelection :: IDEAction +reloadKeepSelection = do + mbMod <- getPane + case mbMod of + Nothing -> return () + Just mods@(IDEModules _ _ treeView treeStore descrView descrStore _ _ _ _ _) + -> do + mbTreeSelection <- liftIO $ getSelectionTree treeView treeStore + mbDescrSelection <- liftIO $ getSelectionDescr descrView descrStore + sc <- getScope + fillModulesList sc + liftIO $ New.treeStoreClear descrStore + let mbs = (case mbTreeSelection of + Nothing -> Nothing + Just (_,[]) -> Nothing + Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md), + case mbDescrSelection of + Nothing -> Nothing + Just fw -> Just (descrName fw)) + selectNames mbs + + +treeStoreGetTreeSave :: New.TreeStore a -> TreePath -> IO (Maybe (Tree a)) +treeStoreGetTreeSave treeStore treePath = catch (do + res <- New.treeStoreGetTree treeStore treePath + return (Just res)) (\ (_ :: SomeException) -> return Nothing) + +expandHere :: TreeView -> IO () +expandHere treeView = do + sel <- treeViewGetSelection treeView + paths <- treeSelectionGetSelectedRows sel + case paths of + [] -> return () + (hd:_) -> treeViewExpandRow treeView hd True >> return () + +collapseHere :: TreeView -> IO () +collapseHere treeView = do + sel <- treeViewGetSelection treeView + paths <- treeSelectionGetSelectedRows sel + case paths of + [] -> return () + (hd:_) -> treeViewCollapseRow treeView hd >> return () + +addModule :: TreeView -> TreeStore (String, [(ModuleDescr,PackageDescr)]) -> IDEAction +addModule treeView store = do + sel <- liftIO $ treeViewGetSelection treeView + paths <- liftIO $ treeSelectionGetSelectedRows sel + case paths of + [] -> return () + (treePath:_) -> do + categories <- liftIO $ mapM (treeStoreGetValue store) + $ map (\n -> take n treePath) [1 .. length treePath] + mbPD <- getPackageDescriptionAndPath + case mbPD of + Nothing -> ideMessage Normal "No package description" + Just (pd,cabalPath) -> let srcPaths = concatMap hsSourceDirs $ allBuildInfo pd + rootPath = dropFileName cabalPath + modPath = foldr (\a b -> a ++ "." ++ b) "" + (map fst categories) + in do + mbResp <- liftIO $ addModuleDialog modPath srcPaths + case mbResp of + Nothing -> return () + Just (AddModule modPath srcPath isExposed) -> + let splitter = split '.' modPath + (modPaths,[modName])= splitAt (length splitter - 1) splitter + targetPath = foldl' () (rootPath srcPath) modPaths + targetFile = targetPath (modName ++ ".hs") + in do + liftIO $ createDirectoryIfMissing True targetPath + alreadyExists <- liftIO $ doesFileExist targetFile + if alreadyExists + then ideMessage Normal "File already exists" + else do + template <- liftIO $ getModuleTemplate pd modName + liftIO $ writeFile targetFile template + addModuleToPackageDescr + (forceJust (simpleParse modPath) + ("Modules>>addModule Can't parse module name " ++ modPath)) + isExposed + packageConfig + rebuildActiveInfo + trace ("now openening " ++ targetFile) $ return () + fileOpenThis targetFile + + +-- |* Yet another stupid little dialog + +data AddModule = AddModule {moduleName :: String, sourceRoot :: FilePath, isExposed :: Bool} + +addModuleDialog :: String -> [String] -> IO (Maybe AddModule) +addModuleDialog modString sourceRoots = do + dia <- dialogNew + windowSetTitle dia "Construct new module" + upper <- dialogGetUpper dia + lower <- dialogGetActionArea dia + (widget,inj,ext,_) <- buildEditor (moduleFields sourceRoots) + (AddModule modString (head sourceRoots) False) + (widget2,_,_,notifier) <- buildEditor okCancelFields () + registerEvent notifier Clicked (Left (\e -> do + case eventPaneName e of + "Ok" -> dialogResponse dia ResponseOk + _ -> dialogResponse dia ResponseCancel + return e)) + boxPackStart upper widget PackGrow 7 + boxPackStart lower widget2 PackNatural 7 + widgetShowAll dia + resp <- dialogRun dia + value <- ext (AddModule modString (head sourceRoots) False) + widgetDestroy dia + --find + case resp of + ResponseOk -> return value + _ -> return Nothing + +moduleFields :: [FilePath] -> FieldDescription AddModule +moduleFields list = VFD emptyParams [ + mkField + (paraName <<<- ParaName ("New module ") + $ emptyParams) + moduleName + (\ a b -> b{moduleName = a}) + (stringEditor (\s -> True)), + mkField + (paraName <<<- ParaName ("Root of the source path") + $ paraMultiSel <<<- ParaMultiSel False + $ emptyParams) + (\a -> [sourceRoot a]) + (\ a b -> b{sourceRoot = forceHead a "Modules>>moduleFields"}) + (staticListEditor list), + mkField + (paraName <<<- ParaName ("Is this an exposed library module") + $ emptyParams) + isExposed + (\ a b -> b{isExposed = a}) + boolEditor] + +-- * GUI History + +data SelectionState = SelectionState { + moduleS' :: Maybe ModuleName +, facetS' :: Maybe String +, scope' :: Scope +, blacklist' :: Bool} + deriving (Eq,Ord,Show) + +recordSelHistory :: IDEAction +recordSelHistory = do + mods <- getModules + ideR <- ask + selTree <- liftIO $ getSelectionTree (treeView mods) (treeStore mods) + selDescr <- liftIO $ getSelectionDescr (descrView mods) (descrStore mods) + let selMod = case selTree of + Nothing -> Nothing + Just (_,[]) -> Nothing + Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md) + let selFacet = case selDescr of + Nothing -> Nothing + Just descr -> Just (descrName descr) + oldSel <- liftIO $ readIORef (oldSelection mods) + triggerEvent ideR (RecordHistory ((ModuleSelected selMod selFacet), + (ModuleSelected (moduleS' oldSel) (facetS' oldSel)))) + liftIO $ writeIORef (oldSelection mods) (oldSel{moduleS'= selMod, facetS' = selFacet}) + return () + +replaySelHistory :: Maybe ModuleName -> Maybe Symbol -> IDEAction +replaySelHistory mbModName mbFacetName = do + mods <- getModules + selectNames (mbModName, mbFacetName) + oldSel <- liftIO $ readIORef (oldSelection mods) + liftIO $ writeIORef (oldSelection mods) + (oldSel{moduleS'= mbModName, facetS' = mbFacetName}) + +recordScopeHistory :: IDEAction +recordScopeHistory = do + (sc,bl) <- getScope + ideR <- ask + mods <- getModules + oldSel <- liftIO $ readIORef (oldSelection mods) + triggerEvent ideR (RecordHistory ((ScopeSelected sc bl), + (ScopeSelected (scope' oldSel) (blacklist' oldSel)))) + liftIO $ writeIORef (oldSelection mods) (oldSel{scope'= sc, blacklist' = bl}) + return () + +replayScopeHistory :: Scope -> Bool -> IDEAction +replayScopeHistory sc bl = do + mods@(IDEModules _ _ _ _ _ _ localScopeB packageScopeB worldScopeB blacklistB _) + <- getModules + liftIO $ do + toggleButtonSetActive blacklistB bl + toggleButtonSetActive localScopeB (sc == Local) + toggleButtonSetActive packageScopeB (sc == Package) + toggleButtonSetActive worldScopeB (sc == System) + setScope (sc,bl) + oldSel <- liftIO $ readIORef (oldSelection mods) + liftIO $ writeIORef (oldSelection mods) (oldSel{scope'= sc, blacklist' = bl}) diff --git a/src/IDE/Pane/PackageEditor.hs b/src/IDE/Pane/PackageEditor.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Pane/PackageEditor.hs @@ -0,0 +1,724 @@ +{-# OPTIONS_GHC -XScopedTypeVariables -XDeriveDataTypeable -XMultiParamTypeClasses + -XTypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Pane.PackageEditor +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | Module for editing of cabal packages and build infos +-- +----------------------------------------------------------------------------------- + + +module IDE.Pane.PackageEditor ( + packageNew' +, packageEdit +, choosePackageDir +, choosePackageFile + +, hasConfigs +) where + +import Graphics.UI.Gtk +import Control.Monad.Reader +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Verbosity +import System.FilePath +import Data.List +import Data.Maybe +import System.Directory + +import IDE.Core.State +import IDE.FileUtils +import IDE.SpecialEditors +import Graphics.UI.Editor.MakeEditor +import Distribution.PackageDescription.Parse (readPackageDescription,writePackageDescription) +import Distribution.PackageDescription.Configuration (freeVars,flattenPackageDescription) +import Distribution.ModuleName(ModuleName) +import Data.Typeable (Typeable(..)) +import Debug.Trace (trace) +import IDE.Metainfo.InterfaceCollector (getInstalledPackageInfos) +import qualified Distribution.InstalledPackageInfo as IPI (package) +import Graphics.UI.Editor.Composite (maybeEditor,pairEditor,ColumnDescr(..),multisetEditor) +import qualified Graphics.UI.Gtk as New (cellText) +import Distribution.Text (simpleParse,display) +import MyMissing +import Graphics.UI.Editor.Parameters (Parameter(..),paraPack,Direction(..),paraDirection,paraMinSize,paraShadow,paraSynopsis,(<<<-),emptyParams,paraName,getParameterPrim) +import Graphics.UI.Editor.Simple (boolEditor,fileEditor,comboSelectionEditor,multilineStringEditor,stringEditor) +import Distribution.License (License(..)) + +-- --------------------------------------------------------------------- +-- The exported stuff goes here +-- + +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 + mbActivePackage <- readIDE activePack + case mbActivePackage of + Nothing -> sysMessage Normal "No active package to edit" + Just idePackage -> do + let dirName = dropFileName (cabalFile idePackage) + modules <- liftIO $ allModules dirName + package <- liftIO $ readPackageDescription normal (cabalFile idePackage) + if hasConfigs package + then do + ideMessage High ("Cabal File with configurations can't be edited with the" + ++ "Current version of the editor") + return () + else do + editPackage (flattenPackageDescription package) dirName modules (\ _ -> return ()) + return () + +hasConfigs :: GenericPackageDescription -> Bool +hasConfigs gpd = + let freeVars1 = case condLibrary gpd of + Nothing -> [] + Just ct -> freeVars ct + freeVars2 = concatMap (freeVars . snd) (condExecutables gpd) + in trace ("freeVars " ++ show freeVars1 ++ "-" ++ show freeVars2) + $ not (null freeVars1 && null freeVars2) + +packageNew' :: (FilePath -> IDEAction) -> IDEAction +packageNew' activateAction = do + window <- readIDE window + mbDirName <- liftIO $ choosePackageDir window + case mbDirName of + Nothing -> return () + Just dirName -> do + cfn <- liftIO $ cabalFileName dirName + continue <- do + if isJust cfn + then liftIO $ 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 <- liftIO $ 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{buildType = Just Simple} dirName modules activateAction + return () + +standardSetup = "#!/usr/bin/runhaskell \n" + ++ "> module Main where\n" + ++ "> import Distribution.Simple\n" + ++ "> main :: IO ()\n" + ++ "> main = defaultMain\n\n" + +-- --------------------------------------------------------------------- +-- | We do some twist for handling build infos seperately to edit them in one editor together +-- with the other stuff. This type show what we really edit here +-- + +data PackageDescriptionEd = PDE { + pd :: PackageDescription, + exes :: [Executable'], + mbLib :: Maybe Library', + bis :: [BuildInfo]} + +fromEditor :: PackageDescriptionEd -> PackageDescription +fromEditor (PDE pd exes' mbLib' buildInfos) = + let exes = map (\ (Executable' s fb bii) -> if bii + 1 > length buildInfos + then Executable s fb (buildInfos !! (length buildInfos - 1)) + else Executable s fb (buildInfos !! bii)) exes' + mbLib = case mbLib' of + Nothing -> Nothing + Just (Library' mn b bii) -> if bii + 1 > length buildInfos + then Just (Library mn b (buildInfos !! (length buildInfos - 1))) + else Just (Library mn b (buildInfos !! bii)) + in pd {library = mbLib, executables = exes} + +toEditor :: PackageDescription -> PackageDescriptionEd +toEditor pd = + let (exes,bis) = unzip $ map (\ ((Executable s fb bi), i) -> (Executable' s fb i, bi)) + (zip (executables pd) [0 .. length (executables pd)]) + (mbLib,bis2) = case library pd of + Nothing -> (Nothing,bis) + Just (Library mn b bi) -> (Just (Library' mn b (length bis)), bis ++ [bi]) + bis3 = if null bis2 + then [emptyBuildInfo] + else bis2 + in PDE (pd {library = Nothing , executables = []}) exes mbLib bis3 + +-- --------------------------------------------------------------------- +-- The pane stuff +-- + +data PackagePane = PackagePane { + packageBox :: VBox +} deriving Typeable + +instance IDEObject PackagePane + +data PackageState = PackageState + deriving (Read, Show, Typeable) + +instance Pane PackagePane IDEM + where + primPaneName _ = "Package" + getAddedIndex _ = 0 + getTopWidget = castToWidget . packageBox + paneId b = "*Package" + makeActive p = activatePane p [] + close pane = do + (panePath,_) <- guiPropertiesFromName (paneName pane) + nb <- getNotebook panePath + mbI <- liftIO $notebookPageNum nb (getTopWidget pane) + case mbI of + Nothing -> liftIO $ do + sysMessage Normal "notebook page not found: unexpected" + return () + Just i -> do + deactivatePaneIfActive pane + liftIO $ do + notebookRemovePage nb i + widgetDestroy (getTopWidget pane) + removePaneAdmin pane + +instance RecoverablePane PackagePane PackageState IDEM where + saveState p = return Nothing + recoverState pp st = return () + +editPackage :: PackageDescription -> FilePath -> [ModuleName] -> (FilePath -> IDEAction) -> IDEAction +editPackage packageD packagePath modules afterSaveAction = do + mbPane :: Maybe PackagePane <- getPane + case mbPane of + Nothing -> do + ideR <- ask + prefs <- readIDE prefs + layout <- readIDE layout + let pp = getStandardPanePath (sourcePanePath prefs) layout + nb <- getNotebook pp + packageInfos <- lift $ getInstalledPackageInfos + let packageEd = toEditor packageD + initPackage packagePath packageEd + (packageDD + (map IPI.package packageInfos) + (takeDirectory packagePath) + modules + (length (bis packageEd)) + (concatMap (buildInfoD (Just (takeDirectory packagePath)) modules) + [0..length (bis packageEd) - 1])) + pp nb modules afterSaveAction + Just p -> liftIO $ bringPaneToFront p + +initPackage :: FilePath + -> PackageDescriptionEd + -> FieldDescription PackageDescriptionEd + -> PanePath + -> Notebook + -> [ModuleName] + -> (FilePath -> IDEAction) + -> IDEM () +initPackage packageDir packageD packageDescr panePath nb2 modules afterSaveAction = do + let fields = trace ("initPackage called " ++ packageDir) $ flattenFieldDescription packageDescr + let initialPackagePath = packageDir (display . pkgName . package . pd) packageD ++ ".cabal" + liftIO $ setCurrentDirectory packageDir + panes <- readIDE panes + window <- readIDE window + paneMap <- readIDE paneMap + currentInfo <- readIDE currentInfo + packageInfos <- lift $ getInstalledPackageInfos + (buf,cids) <- reifyIDE $ \ideR session -> do + vb <- vBoxNew False 0 + let packagePane = PackagePane vb + bb <- hButtonBoxNew + restore <- buttonNewFromStock "Revert" + save <- buttonNewFromStock "gtk-save" + closeB <- buttonNewFromStock "gtk-close" + addB <- buttonNewFromStock "Add Build Info" + removeB <- buttonNewFromStock "Remove Build Info" + boxPackStart bb addB PackNatural 0 + boxPackStart bb removeB PackNatural 0 + boxPackStart bb restore PackNatural 0 + boxPackStart bb save PackNatural 0 + boxPackStart bb closeB PackNatural 0 + (widget, setInj, getExt, notifier) <- buildEditor packageDescr packageD + let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of + Just s -> s + Nothing -> "Unnamed") fields + save `onClicked` (do + mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames + case mbNewPackage' of + Nothing -> return () + Just newPackage' -> let newPackage = fromEditor newPackage' in do + let packagePath = packageDir (display . pkgName . package . pd) newPackage' + ++ ".cabal" + writePackageDescription packagePath newPackage + reflectIDE (afterSaveAction packagePath) ideR session) + closeB `onClicked` (do + mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames + case mbNewPackage' of + Nothing -> do + md <- messageDialogNew Nothing [] MessageQuestion ButtonsYesNo + "Package does not validate. Close anyway?" + rid <- dialogRun md + widgetDestroy md + case rid of + ResponseYes -> (reflectIDE (close packagePane) ideR session) + otherwise -> return () + Just newPackage -> do + let packagePath = packageDir (display . pkgName . package . pd) newPackage + modified <- do + exists <- liftIO $ doesFileExist packagePath + if exists + then do + packageNow <- readPackageDescription normal packagePath + let simpleNow = flattenPackageDescription packageNow + case mbNewPackage' of + Nothing -> return True --doesn't validate, so something has changed + Just pd -> return (fromEditor pd /= + simpleNow{buildDepends = reverse (buildDepends simpleNow)}) + else return False + cancel <- if modified + then do + md <- messageDialogNew (Just window) [] + MessageQuestion + ButtonsNone + ("Save changes to Cabal file: " + ++ packagePath + ++ "?") + dialogAddButton md "_Save" ResponseYes + dialogAddButton md "_Don't Save" ResponseNo + dialogAddButton md "_Cancel" ResponseCancel + resp <- dialogRun md + widgetDestroy md + case resp of + ResponseYes -> do + case mbNewPackage' of + Nothing -> return False + Just newPackage' -> let newPackage = fromEditor newPackage' in do + let PackageIdentifier (PackageName n) v = package newPackage + writePackageDescription packagePath newPackage + return False + ResponseCancel -> return True + ResponseNo -> return False + _ -> return False + else return False + when (not cancel) (reflectIDE (close packagePane) ideR session)) + restore `onClicked` (do + package <- readPackageDescription normal initialPackagePath + setInj (toEditor (flattenPackageDescription package))) + addB `onClicked` (do + mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames + case mbNewPackage' of + Nothing -> sysMessage Normal "Content doesn't validate" + Just pde -> do + reflectIDE (do + close packagePane + initPackage packageDir pde {bis = bis pde ++ [bis pde !! 0]} + (packageDD + (map IPI.package packageInfos) + packageDir + modules + (length (bis pde) + 1) + (concatMap (buildInfoD (Just packageDir) modules) + [0..length (bis pde)])) + panePath nb2 modules afterSaveAction) ideR session) + removeB `onClicked` (do + mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames + case mbNewPackage' of + Nothing -> sysMessage Normal "Content doesn't validate" + Just pde | length (bis pde) == 1 -> sysMessage Normal "Just one Build Info" + | otherwise -> reflectIDE (do + close packagePane + initPackage packageDir pde{bis = take (length (bis pde) - 1) (bis pde)} + (packageDD + (map IPI.package packageInfos) + packageDir + modules + (length (bis pde) - 1) + (concatMap (buildInfoD (Just packageDir) modules) + [0..length (bis pde) - 2])) + panePath nb2 modules afterSaveAction) ideR session) + boxPackStart vb widget PackGrow 7 + boxPackEnd vb bb PackNatural 7 + widgetShowAll vb + i <- notebookInsertOrdered nb2 vb (paneName packagePane) Nothing + return (packagePane,[]) + addPaneAdmin buf [] panePath + liftIO $widgetGrabFocus (packageBox buf) + +-- --------------------------------------------------------------------- +-- The description with some tricks +-- + +packageDD :: [PackageIdentifier] + -> FilePath + -> [ModuleName] + -> Int + -> [(String, FieldDescription PackageDescriptionEd)] + -> FieldDescription PackageDescriptionEd +packageDD packages fp modules numBuildInfos extras = NFD ([ + ("Package", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Synopsis" + $ paraSynopsis <<<- ParaSynopsis "A one-line summary of this package" + $ emptyParams) + (synopsis . pd) + (\ a b -> b{pd = (pd b){synopsis = a}}) + (stringEditor (const True)) + , mkField + (paraName <<<- ParaName "Package Identifier" $ emptyParams) + (package . pd) + (\ a b -> b{pd = (pd b){package = a}}) + packageEditor + , mkField + (paraName <<<- ParaName "Description" + $ paraSynopsis <<<- ParaSynopsis "A more verbose description of this package" + $ paraShadow <<<- ParaShadow ShadowOut + $ paraMinSize <<<- ParaMinSize (-1,250) + $ emptyParams) + (description . pd) + (\ a b -> b{pd = (pd b){description = if null a then " \n\n\n\n\n" else a}}) + multilineStringEditor + , mkField + (paraName <<<- ParaName "Homepage" $ emptyParams) + (homepage . pd) + (\ a b -> b{pd = (pd b){homepage = a}}) + (stringEditor (const True)) + , mkField + (paraName <<<- ParaName "Package URL" $ emptyParams) + (pkgUrl . pd) + (\ a b -> b{pd = (pd b){pkgUrl = a}}) + (stringEditor (const True)) + , mkField + (paraName <<<- ParaName "Category" $ emptyParams) + (category . pd) + (\ a b -> b{pd = (pd b){category = a}}) + (stringEditor (const True)) + ]), + ("Description", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Stability" $ emptyParams) + (stability . pd) + (\ a b -> b{pd = (pd b){stability = a}}) + (stringEditor (const True)) + , mkField + (paraName <<<- ParaName "License" $ emptyParams) + (license . pd) + (\ a b -> b{pd = (pd b){license = a}}) + (comboSelectionEditor [GPL, LGPL, BSD3, BSD4, PublicDomain, AllRightsReserved, OtherLicense]) + , mkField + (paraName <<<- ParaName "License File" $ emptyParams) + (licenseFile . pd) + (\ a b -> b{pd = (pd b){licenseFile = a}}) + (fileEditor (Just fp) FileChooserActionOpen "Select file") + , mkField + (paraName <<<- ParaName "Copyright" $ emptyParams) + (copyright . pd) + (\ a b -> b{pd = (pd b){copyright = a}}) + (stringEditor (const True)) + , mkField + (paraName <<<- ParaName "Author" $ emptyParams) + (author . pd) + (\ a b -> b{pd = (pd b){author = a}}) + (stringEditor (const True)) + , mkField + (paraName <<<- ParaName "Maintainer" $ emptyParams) + (maintainer . pd) + (\ a b -> b{pd = (pd b){maintainer = a}}) + (stringEditor (const True)) + ]), + ("Dependencies ", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Build Dependencies" + $ paraSynopsis <<<- ParaSynopsis "Does this package depends on other packages?" + $ paraDirection <<<- ParaDirection Vertical + $ paraPack <<<- ParaPack PackGrow + $ emptyParams) + (reverse . buildDepends . pd) + (\ a b -> b{pd = (pd b){buildDepends = a}}) + (dependenciesEditor packages) + ]), + ("Meta Dep.", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Cabal version" + $ paraSynopsis <<<- ParaSynopsis + "Does this package depends on a specific version of Cabal?" + $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams) + (descCabalVersion . pd) + (\ a b -> b{pd = (pd b){descCabalVersion = a}}) + versionRangeEditor + , mkField + (paraName <<<- ParaName "Tested with compiler" + $ paraShadow <<<- ParaShadow ShadowIn + $ paraDirection <<<- ParaDirection Vertical + $ emptyParams) + (\a -> case (testedWith . pd) a of + [] -> []--(GHC,AnyVersion)] + l -> l) + (\ a b -> b{pd = (pd b){testedWith = a}}) + testedWidthEditor + ]), + ("Extra Files", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Data Files" + $ paraSynopsis <<<- ParaSynopsis + "A list of files to be installed for run-time use by the package." + $ paraDirection <<<- ParaDirection Vertical + $ paraMinSize <<<- ParaMinSize (-1,130) + $ emptyParams) + (dataFiles . pd) + (\ a b -> b{pd = (pd 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 + $ paraMinSize <<<- ParaMinSize (-1,130) + $ emptyParams) + (extraSrcFiles . pd) + (\ a b -> b{pd = (pd 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 + $ paraMinSize <<<- ParaMinSize (-1,130) + $ emptyParams) + (extraTmpFiles . pd) + (\ a b -> b{pd = (pd b){extraTmpFiles = a}}) + (filesEditor (Just fp) FileChooserActionOpen "Select File") + ]), + ("Executables",VFD emptyParams [ + mkField + (paraName <<<- ParaName "Executables" + $ paraSynopsis <<<- ParaSynopsis + "Describe executable programs contained in the package" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + exes + (\ a b -> b{exes = a}) + (executablesEditor (Just fp) modules numBuildInfos) + ]), + ("Library", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Library" + $ paraSynopsis <<<- ParaSynopsis + "If the package contains a library, specify the exported modules here" + $ paraDirection <<<- ParaDirection Vertical + $ paraPack <<<- ParaPack PackGrow + $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams) + mbLib + (\ a b -> b{mbLib = a}) + (maybeEditor (libraryEditor (Just fp) modules numBuildInfos, + paraName <<<- ParaName "Specify exported modules" + $ paraPack <<<- ParaPack PackGrow + $ emptyParams) True + "Does this package contain a library?") + ]) + ] ++ extras) + +update :: [BuildInfo] -> Int -> (BuildInfo -> BuildInfo) -> [BuildInfo] +update bis index func = + map (\(bi,ind) -> if ind == index + then func bi + else bi) + (zip bis [0..length bis - 1]) + +buildInfoD :: Maybe FilePath -> [ModuleName] -> Int -> [(String,FieldDescription PackageDescriptionEd)] +buildInfoD fp modules i = [ + (show (i + 1) ++ " Build Info", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Component is buildable here" $ emptyParams) + (buildable . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{buildable = a})}) + boolEditor + , mkField + (paraName <<<- ParaName + "Where to look for the source hierarchy" + $ paraSynopsis <<<- ParaSynopsis + "Root directories for the source hierarchy." + $ paraShadow <<<- ParaShadow ShadowIn + $ paraDirection <<<- ParaDirection Vertical + $ emptyParams) + (hsSourceDirs . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{hsSourceDirs = a})}) + (filesEditor fp FileChooserActionSelectFolder "Select folder") + , 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 + $ paraMinSize <<<- ParaMinSize (-1,400) + $ paraPack <<<- ParaPack PackGrow + $ emptyParams) + (map display. otherModules . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> + bi{otherModules = (map (\i -> forceJust (simpleParse i) + " PackageEditor >> buildInfoD: no parse for moduile name" ) a)})}) + (modulesEditor modules) + ]), + (show (i + 1) ++ " Compiler ", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Options for haskell compilers" + $ paraDirection <<<- ParaDirection Vertical + $ paraShadow <<<- ParaShadow ShadowIn + $ paraPack <<<- ParaPack PackGrow $ emptyParams) + (options . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{options = a})}) + (multisetEditor + (ColumnDescr True [("Compiler Flavor",\(cv,_) -> [New.cellText := show cv]) + ,("Options",\(_,op) -> [New.cellText := concatMap (\s -> ' ' : s) op])]) + ((pairEditor + (compilerFlavorEditor,emptyParams) + (stringsEditor (const True),emptyParams)), + (paraDirection <<<- ParaDirection Vertical + $ paraMinSize <<<- ParaMinSize (-1,400) + $ paraPack <<<- ParaPack PackGrow + $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams))) + , mkField + (paraName <<<- ParaName "Additional options for GHC when built with profiling" + $ paraDirection <<<- ParaDirection Vertical + $ emptyParams) + (ghcProfOptions . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{ghcProfOptions = a})}) + (stringsEditor (const True)) + ]), + (show (i + 1) ++ " Extensions ", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Extensions" + $ paraSynopsis <<<- ParaSynopsis + "A list of Haskell extensions used by every module." + $ paraMinSize <<<- ParaMinSize (-1,400) + $ paraPack <<<- ParaPack PackGrow + $ emptyParams) + (extensions . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{extensions = a})}) + extensionsEditor + ]), + (show (i + 1) ++ " Opts C ", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Options for C compiler" + $ paraDirection <<<- ParaDirection Vertical + $ emptyParams) + (ccOptions . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{ccOptions = a})}) + (stringsEditor (const True)) + , mkField + (paraName <<<- ParaName "Options for linker" + $ paraDirection <<<- ParaDirection Vertical + $ emptyParams) + (ldOptions . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{ldOptions = a})}) + (stringsEditor (const True)) + , mkField + (paraName <<<- ParaName "A list of header files already installed on the system" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + (includes . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{includes = a})}) + (stringsEditor (const True)) + , mkField + (paraName <<<- ParaName "A list of header files from this package" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + (installIncludes . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{installIncludes = a})}) + (filesEditor fp FileChooserActionOpen "Select File") + ]), + (show (i + 1) ++ " More Opts C", VFD emptyParams [ + mkField + (paraName <<<- ParaName "A list of directories to search for header files" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + (includeDirs . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{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 -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{cSources = a})}) + (filesEditor fp FileChooserActionOpen "Select file") + , mkField + (paraName <<<- ParaName "A list of extra libraries to link with" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + (extraLibs . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{extraLibs = a})}) + (stringsEditor (const True)) + , mkField + (paraName <<<- ParaName "A list of directories to search for libraries." + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + (extraLibDirs . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{extraLibDirs = a})}) + (filesEditor fp FileChooserActionSelectFolder "Select Folder") + ]), + (show (i + 1) ++ " Opts OSX", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Support frameworks for Mac OS X" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + (cSources . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{cSources = a})}) + (stringsEditor (const True)) + ])] + diff --git a/src/IDE/Pane/PackageFlags.hs b/src/IDE/Pane/PackageFlags.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Pane/PackageFlags.hs @@ -0,0 +1,268 @@ +{-# OPTIONS_GHC -XScopedTypeVariables -XDeriveDataTypeable -XMultiParamTypeClasses + -XTypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Pane.PackageFlags +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- +-- | Module for saving, restoring and editing projectFlags +-- +--------------------------------------------------------------------------------- + + +module IDE.Pane.PackageFlags ( + readFlags +, writeFlags +, getFlags +, IDEFlags(..) +, FlagsState +) 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 Data.Typeable +import System.FilePath.Posix + +import IDE.Core.State +import Graphics.UI.Editor.Basics +import Graphics.UI.Editor.MakeEditor +import Graphics.UI.Editor.Simple +import Graphics.UI.Editor.Parameters + +import IDE.PrinterParser hiding (fieldParser,parameters) + +import Control.Event (registerEvent) +import IDE.DescriptionPP (extractFieldDescription,FieldDescriptionPP(..), + mkFieldPP,flattenFieldDescriptionPP) + +data IDEFlags = IDEFlags { + flagsBox :: VBox +} deriving Typeable + +data FlagsState = FlagsState + deriving(Eq,Ord,Read,Show,Typeable) + +instance IDEObject IDEFlags + +instance Pane IDEFlags IDEM + where + primPaneName _ = "Package Flags" + getAddedIndex _ = 0 + getTopWidget = castToWidget . flagsBox + paneId b = "*Flags" + makeActive prefs = activatePane prefs [] + close pane = do + (panePath,_) <- guiPropertiesFromName (paneName pane) + nb <- getNotebook panePath + mbI <- liftIO $notebookPageNum nb (getTopWidget pane) + case mbI of + Nothing -> liftIO $ do + sysMessage Normal "notebook page not found: unexpected" + return () + Just i -> do + deactivatePaneIfActive pane + liftIO $ do + notebookRemovePage nb i + widgetDestroy (getTopWidget pane) + removePaneAdmin pane + +instance RecoverablePane IDEFlags FlagsState IDEM where + saveState p = do + mbFlags :: Maybe IDEFlags <- getPane + case mbFlags of + Nothing -> return Nothing + Just p -> return (Just FlagsState) + recoverState pp st = do + mbPack <- readIDE activePack + case mbPack of + Just pack -> do + nb <- getNotebook pp + initFlags pack pp nb + Nothing -> return () + + +concatString :: [String] -> String +concatString l = foldl' (\r s -> if null r then s else r ++ " " ++ s) "" l + +flatFlagsDescription :: [FieldDescriptionPP IDEPackage] +flatFlagsDescription = flattenFieldDescriptionPP flagsDescription + +flagsDescription :: FieldDescriptionPP IDEPackage +flagsDescription = VFDPP emptyParams [ + 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 (const True)) + (\ _ -> 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 (const True)) + (\ _ -> 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 (const True)) + (\ _ -> 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 (const True)) + (\ _ -> 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 (const True)) + (\ _ -> 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 (const True)) + (\ _ -> 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 (const True)) + (\ _ -> 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 (const True)) + (\ _ -> return ())] + +-- ------------------------------------------------------------ +-- * Parsing +-- ------------------------------------------------------------ + +readFlags :: FilePath -> IDEPackage -> IO IDEPackage +readFlags fn pack = do + res <- P.parseFromFile (flagsParser pack flatFlagsDescription) 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 flatFlagsDescription) + +showFlags :: a -> [FieldDescriptionPP a] -> String +showFlags flags flagsDesc = PP.render $ + foldl' (\ doc (FDPP _ printer _ _ _ ) -> doc PP.$+$ printer flags) PP.empty flagsDesc + +-- ------------------------------------------------------------ +-- * Editing +-- ------------------------------------------------------------ + +getFlags :: IDEM (Maybe IDEFlags) +getFlags = do + mbFlags <- getPane + case mbFlags of + Nothing -> do + mbPack <- readIDE activePack + case mbPack of + Nothing -> do + ideMessage Normal "can't edit flags without active package" + return Nothing + Just pack -> do + prefs <- readIDE prefs + layout <- readIDE layout + let pp = getStandardPanePath (sourcePanePath prefs) layout + nb <- getNotebook pp + initFlags pack pp nb + mbFlags <- getPane + case mbFlags of + Nothing -> throwIDE "Can't init flags pane" + Just m -> do + liftIO $bringPaneToFront m + return (Just m) + Just m -> do + liftIO $bringPaneToFront m + return (Just m) + +initFlags :: IDEPackage -> PanePath -> Notebook -> IDEAction +initFlags idePackage panePath nb = do + let flagsDesc = extractFieldDescription flagsDescription + let flatflagsDesc = flattenFieldDescription flagsDesc + (buf,cids) <- reifyIDE $ \ ideR session -> do + vb <- vBoxNew False 0 + let flagsPane = IDEFlags vb + bb <- hButtonBoxNew + ok <- buttonNewFromStock "gtk-ok" + closeB <- buttonNewFromStock "gtk-close" + boxPackStart bb ok PackNatural 0 + boxPackStart bb closeB PackNatural 0 + (widget,injb,ext,notifier) + <- buildEditor flagsDesc idePackage + sw <- scrolledWindowNew Nothing Nothing + scrolledWindowAddWithViewport sw widget + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + ok `onClicked` (do + mbPackWithNewFlags <- extract idePackage [ext] + case mbPackWithNewFlags of + Nothing -> return () + Just packWithNewFlags -> do + reflectIDE (do + modifyIDE_ (\ide -> return (ide{activePack = Just packWithNewFlags})) + close flagsPane) ideR session -- we don't trigger the activePack event here + writeFlags ((dropFileName (cabalFile packWithNewFlags)) "IDE.flags") + packWithNewFlags) + closeB `onClicked` (reflectIDE (close flagsPane) ideR session) + registerEvent notifier FocusIn (Left (\e -> do + reflectIDE (makeActive flagsPane) ideR session + return (e{gtkReturn=False}))) + boxPackStart vb sw PackGrow 7 + boxPackEnd vb bb PackNatural 7 + notebookInsertOrdered nb vb (paneName flagsPane) Nothing + widgetShowAll vb + return (flagsPane,[]) + addPaneAdmin buf [] panePath + liftIO $widgetGrabFocus (flagsBox buf) + + + diff --git a/src/IDE/Pane/Preferences.hs b/src/IDE/Pane/Preferences.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Pane/Preferences.hs @@ -0,0 +1,467 @@ +{-# OPTIONS_GHC -XScopedTypeVariables -XDeriveDataTypeable -XMultiParamTypeClasses + -XTypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Pane.Preferences +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- +-- | Module for saving, restoring and editing preferences +-- +--------------------------------------------------------------------------------- + + +module IDE.Pane.Preferences ( + IDEPrefs(..) +, PrefsState +, 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 Data.Typeable + +import Control.Event +import Graphics.UI.Editor.Basics +import IDE.Core.State +import Graphics.UI.Editor.Simple +import Graphics.UI.Editor.Composite +import Graphics.UI.Editor.Parameters +import Graphics.UI.Editor.MakeEditor hiding (parameters) +import IDE.DescriptionPP +import IDE.PrinterParser hiding (fieldParser,parameters) +import IDE.Pane.SourceBuffer +import IDE.Pane.Log +import IDE.SpecialEditors +import Default +import IDE.FileUtils +import System.IO +import Distribution.InstalledPackageInfo (package) + +-- +-- | The Preferences Pane +-- + +data IDEPrefs = IDEPrefs { + prefsBox :: VBox +} deriving Typeable + +data PrefsState = PrefsState + deriving(Eq,Ord,Read,Show,Typeable) + +instance IDEObject IDEPrefs + +instance Pane IDEPrefs IDEM + where + primPaneName _ = "Prefs" + getAddedIndex _ = 0 + getTopWidget = castToWidget . prefsBox + paneId b = "*Prefs" + makeActive prefs = activatePane prefs [] + close pane = do + (panePath,_) <- guiPropertiesFromName (paneName pane) + nb <- getNotebook panePath + mbI <- liftIO $notebookPageNum nb (getTopWidget pane) + case mbI of + Nothing -> liftIO $ do + sysMessage Normal "notebook page not found: unexpected" + return () + Just i -> do + deactivatePaneIfActive pane + liftIO $ do + notebookRemovePage nb i + widgetDestroy (getTopWidget pane) + removePaneAdmin pane + +instance RecoverablePane IDEPrefs PrefsState IDEM where + saveState p = return Nothing + recoverState pp st = return () + +-- ------------------------------------------------------------ +-- * Editing +-- ------------------------------------------------------------ + +editPrefs :: IDEAction +editPrefs = do + getPrefs + return () + +getPrefs :: IDEM IDEPrefs +getPrefs = do + mbPrefs <- getPane + case mbPrefs of + Nothing -> do + prefs <- readIDE prefs + layout <- readIDE layout + let pp = getStandardPanePath (sourcePanePath prefs) layout + nb <- getNotebook pp + initPrefs pp nb + mbPrefs <- getPane + case mbPrefs of + Nothing -> throwIDE "Can't init prefs pane" + Just m -> do + liftIO $bringPaneToFront m + return m + Just m -> do + liftIO $bringPaneToFront m + return m + +initPrefs :: PanePath -> Notebook -> IDEAction +initPrefs panePath nb2 = do + packageInfos <- lift $ getInstalledPackageInfos + let flatPrefsDesc = flattenFieldDescriptionPP (prefsDescription (map package packageInfos)) + prefs <- readIDE prefs + lastAppliedPrefsRef <- liftIO $ newIORef prefs + panes <- readIDE panes + paneMap <- readIDE paneMap + currentInfo <- readIDE currentInfo + (buf,cids) <- reifyIDE $ \ideR session -> do + vb <- vBoxNew False 0 + bb <- hButtonBoxNew + apply <- buttonNewFromStock "gtk-apply" + restore <- buttonNewFromStock "Restore" + save <- buttonNewFromStock "gtk-save" + closeB <- buttonNewFromStock "gtk-close" + boxPackStart bb apply PackNatural 0 + boxPackStart bb restore PackNatural 0 + boxPackStart bb save PackNatural 0 + boxPackStart bb closeB PackNatural 0 + (widget,injb,ext,notifier) <- buildEditor (extractFieldDescription $ prefsDescription (map package packageInfos)) prefs + boxPackStart vb widget PackGrow 7 + boxPackEnd vb bb PackNatural 7 + let prefsPane = IDEPrefs vb + apply `onClicked` (do + mbNewPrefs <- extract prefs [ext] + case mbNewPrefs of + Nothing -> return () + Just newPrefs -> do + lastAppliedPrefs <- readIORef lastAppliedPrefsRef + mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF newPrefs lastAppliedPrefs) ideR session) flatPrefsDesc + writeIORef lastAppliedPrefsRef newPrefs) + restore `onClicked` (do + lastAppliedPrefs <- readIORef lastAppliedPrefsRef + mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF prefs lastAppliedPrefs) ideR session) flatPrefsDesc + injb prefs + writeIORef lastAppliedPrefsRef prefs) + save `onClicked` (do + lastAppliedPrefs <- readIORef lastAppliedPrefsRef + mbNewPrefs <- extract prefs [ext] + case mbNewPrefs of + Nothing -> return () + Just newPrefs -> do + mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF newPrefs lastAppliedPrefs) ideR session) flatPrefsDesc + fp <- getConfigFilePathForSave "Default.prefs" + writePrefs fp newPrefs + reflectIDE (modifyIDE_ (\ide -> return (ide{prefs = newPrefs}))) ideR session) + closeB `onClicked` (reflectIDE (close prefsPane) ideR session) + registerEvent notifier FocusIn (Left (\e -> do + reflectIDE (makeActive prefsPane) ideR session + return (e{gtkReturn=False}))) + notebookInsertOrdered nb2 vb (paneName prefsPane) Nothing + widgetShowAll vb + return (prefsPane,[]) + addPaneAdmin buf [] panePath + liftIO $widgetGrabFocus (prefsBox buf) + + +-- ------------------------------------------------------------ +-- * Dialog definition +-- ------------------------------------------------------------ + +prefsDescription :: [PackageIdentifier] -> FieldDescriptionPP Prefs +prefsDescription packages = NFDPP [ + ("Editor", VFDPP emptyParams [ + 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 -> liftIO$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 <- liftIO $fontDescriptionFromString (case mbs of Just str -> str; Nothing -> "") + liftIO $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 + liftIO $sourceViewSetRightMarginPosition (sourceView buf) (fromIntegral n) + liftIO $sourceViewSetShowRightMargin (sourceView buf) True + Nothing -> liftIO $sourceViewSetShowRightMargin (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 -> liftIO $sourceViewSetIndentWidth (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 "Remove trailing blanks when saving a file" $ emptyParams) + (PP.text . show) + boolParser + removeTBlanks + (\b a -> a{removeTBlanks = 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 (\s -> not (null s))), 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 "Editor Style" $ 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))) + sourceStyle + (\b a -> a{sourceStyle = b}) + styleEditor + (\mbs -> do + styleManager <- liftIO sourceStyleSchemeManagerNew + mbStyle <- case mbs of + Nothing -> return Nothing + Just str -> liftIO $ do + ids <- sourceStyleSchemeManagerGetSchemeIds styleManager + if elem str ids + then liftM Just + (sourceStyleSchemeManagerGetScheme styleManager str) + else return Nothing + case mbStyle of + Nothing -> return () + Just style -> do + buffers <- allBuffers + mapM_ (\buf -> do + gtkBuf <- liftIO $ textViewGetBuffer (sourceView buf) + liftIO $ sourceBufferSetStyleScheme (castToSourceBuffer gtkBuf) style) buffers) + ]), + ("GUI Options", VFDPP emptyParams [ + 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 <- liftIO $fontDescriptionFromString (case mbs of Just str -> str; Nothing -> "") + liftIO $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 (\s -> not (null s))) + (\i -> return ()) + , mkFieldPP + (paraName <<<- ParaName "Standard source pane path" $ emptyParams) + (PP.text . show) + readParser + sourcePanePath + (\b a -> a{sourcePanePath = b}) + panePathEditor + (\i -> return ()) + , mkFieldPP + (paraName <<<- ParaName "Standard log pane path" $ emptyParams) + (PP.text . show) + readParser + logPanePath + (\b a -> a{logPanePath = b}) + panePathEditor + (\i -> return ()) + , mkFieldPP + (paraName <<<- ParaName "Standard modules pane path" $ emptyParams) + (PP.text . show) + readParser + modulesPanePath + (\b a -> a{modulesPanePath = b}) + panePathEditor + (\i -> return ()) + , 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 (\s -> not (null s))) + (\ a -> return ()) + ]), + ("Metadata", VFDPP emptyParams [ + 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 packages) + (\i -> return ()) + , mkFieldPP + (paraName <<<- ParaName "Update metadata after every build" $ emptyParams) + (PP.text . show) + boolParser + collectAfterBuild + (\b a -> a{collectAfterBuild = b}) + boolEditor + (\i -> return ()) + , mkFieldPP + (paraName <<<- ParaName "Update metadata at startup" $ emptyParams) + (PP.text . show) + boolParser + collectAtStart + (\b a -> a{collectAtStart = b}) + boolEditor + (\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 + , removeTBlanks = True + , textviewFont = Nothing + , sourceStyle = Nothing + , logviewFont = Nothing + , defaultSize = (1024,800) + , browser = "firefox" + , sourcePanePath = [LeftP] + , logPanePath = [RightP,BottomP] + , modulesPanePath = [RightP,TopP] + , sourceDirectories = [] + , packageBlacklist = [] + , collectAfterBuild = False + , collectAtStart = True + } + +-- ------------------------------------------------------------ +-- * Parsing +-- ------------------------------------------------------------ + +readPrefs :: FilePath -> IO Prefs +readPrefs fn = catch (do + res <- P.parseFromFile (prefsParser defaultPrefs (flattenFieldDescriptionPP + (prefsDescription []))) fn + case res of + Left pe -> throwIDE $ "Error reading prefs file " ++ show fn ++ " " ++ show pe + Right r -> return r) + (\ e -> throwIDE $ "Error reading prefs file " ++ show fn ++ " " ++ show e) + +prefsParser :: a -> [FieldDescriptionPP a] -> P.CharParser () a +prefsParser def descriptions = + let parsersF = map fieldParser descriptions in do + res <- applyFieldParsers def parsersF + return res + P. "prefs parser" + +-- ------------------------------------------------------------ +-- * Printing +-- ------------------------------------------------------------ + +writePrefs :: FilePath -> Prefs -> IO () +writePrefs fpath prefs = writeFile fpath (showPrefs prefs (flattenFieldDescriptionPP (prefsDescription []))) + +showPrefs :: a -> [FieldDescriptionPP a] -> String +showPrefs prefs prefsDesc = PP.render $ + foldl (\ doc (FDPP _ printer _ _ _) -> doc PP.$+$ printer prefs) PP.empty prefsDesc + diff --git a/src/IDE/Pane/Search.hs b/src/IDE/Pane/Search.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Pane/Search.hs @@ -0,0 +1,365 @@ +{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances + -XScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Pane.Search +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | The pane of ide where metadata searches can be done +-- +------------------------------------------------------------------------------- + +module IDE.Pane.Search ( + IDESearch(..) +, SearchState +, showSearch +, setChoices +, searchMetaGUI +) where + +import Graphics.UI.Gtk hiding (get) +import qualified Graphics.UI.Gtk.ModelView as New +import Graphics.UI.Gtk.Gdk.Events +import Data.IORef (newIORef) +import Data.IORef (writeIORef,readIORef,IORef(..)) +import IDE.Pane.Info (setInfo,IDEInfo(..)) +import IDE.Pane.SourceBuffer (goToDefinition) +--import Debug.Trace (trace) +import IDE.Metainfo.Provider (searchMeta) +import Data.Maybe +import Control.Monad.Reader +--import Distribution.Package +import Data.Typeable +import IDE.Core.State +import Distribution.Text(display) +import Control.Event (triggerEvent) + +-- | A search pane description +-- + +data IDESearch = IDESearch { + scrolledView :: ScrolledWindow +, treeView :: New.TreeView +, searchStore :: New.ListStore Descr +, searchStringRef :: IORef String +, searchScopeRef :: IORef Scope +, searchModeRef :: IORef SearchMode +, topBox :: VBox +} deriving Typeable + +data SearchState = SearchState { + searchString :: String +, searchScope :: Scope +, searchMode :: SearchMode +} deriving(Eq,Ord,Read,Show,Typeable) + +instance IDEObject IDESearch + +instance Pane IDESearch IDEM + where + primPaneName _ = "Search" + getAddedIndex _ = 0 + getTopWidget = castToWidget . topBox + paneId b = "*Search" + makeActive p = activatePane p [] + close pane = do + (panePath,_) <- guiPropertiesFromName (paneName pane) + nb <- getNotebook panePath + mbI <- liftIO $notebookPageNum nb (getTopWidget pane) + case mbI of + Nothing -> liftIO $ do + sysMessage Normal "notebook page not found: unexpected" + return () + Just i -> do + deactivatePaneIfActive pane + liftIO $ do + notebookRemovePage nb i + widgetDestroy (getTopWidget pane) + removePaneAdmin pane + +instance RecoverablePane IDESearch SearchState IDEM where + saveState p = do + str <- liftIO $ readIORef (searchStringRef p) + mode <- liftIO $ readIORef (searchModeRef p) + scope <- liftIO $ readIORef (searchScopeRef p) + return (Just (SearchState str scope mode)) + recoverState pp (SearchState str scope mode) = do + nb <- getNotebook pp + initSearch pp nb scope mode + searchMetaGUI str + +showSearch :: IDEAction +showSearch = do + m <- getSearch + liftIO $ bringPaneToFront m + liftIO $ widgetGrabFocus (treeView m) + +getSearch :: IDEM IDESearch +getSearch = do + mbSearch <- getPane + case mbSearch of + Just m -> return m + Nothing -> do + prefs <- readIDE prefs + layout <- readIDE layout + let pp = getStandardPanePath (modulesPanePath prefs) layout + nb <- getNotebook pp + initSearch pp nb System (Prefix False) + mbSearch <- getPane + case mbSearch of + Nothing -> throwIDE "Can't init search" + Just m -> return m + + +initSearch :: PanePath -> Notebook -> Scope -> SearchMode -> IDEAction +initSearch panePath nb scope mode = do + panes <- readIDE panes + paneMap <- readIDE paneMap + prefs <- readIDE prefs + currentInfo <- readIDE currentInfo + (buf,cids) <- reifyIDE $ \ideR session -> do + + scopebox <- hBoxNew True 2 + rb1 <- radioButtonNewWithLabel "Local" + rb2 <- radioButtonNewWithLabelFromWidget rb1 "Package" + rb3 <- radioButtonNewWithLabelFromWidget rb1 "System" + toggleButtonSetActive + (case scope of + Local -> rb1 + Package -> rb2 + System -> rb3) True + boxPackStart scopebox rb1 PackNatural 2 + boxPackStart scopebox rb2 PackNatural 2 + boxPackEnd scopebox rb3 PackNatural 2 + + modebox <- hBoxNew True 2 + mb1 <- radioButtonNewWithLabel "Exact" + mb2 <- radioButtonNewWithLabelFromWidget mb1 "Prefix" + mb3 <- radioButtonNewWithLabelFromWidget mb1 "Regex" + toggleButtonSetActive + (case mode of + Exact _ -> mb1 + Prefix _ -> mb2 + Regex _ -> mb3) True + mb4 <- checkButtonNewWithLabel "Case sensitive" + toggleButtonSetActive mb4 (caseSense mode) + boxPackStart modebox mb1 PackNatural 2 + boxPackStart modebox mb2 PackNatural 2 + boxPackStart modebox mb3 PackNatural 2 + boxPackEnd modebox mb4 PackNatural 2 + + listStore <- New.listStoreNew [] + treeView <- New.treeViewNew + New.treeViewSetModel treeView listStore + + + renderer3 <- New.cellRendererTextNew + renderer30 <- New.cellRendererPixbufNew + col3 <- New.treeViewColumnNew + New.treeViewColumnSetTitle col3 "Symbol" + New.treeViewColumnSetSizing col3 TreeViewColumnAutosize + New.treeViewColumnSetResizable col3 True + New.treeViewColumnSetReorderable col3 True + New.treeViewAppendColumn treeView col3 + New.cellLayoutPackStart col3 renderer30 False + New.cellLayoutPackStart col3 renderer3 True + New.cellLayoutSetAttributes col3 renderer3 listStore + $ \row -> [ New.cellText := descrName row] + New.cellLayoutSetAttributes col3 renderer30 listStore + $ \row -> [ + New.cellPixbufStockId := stockIdFromType ((descrType . details) row)] + + + renderer1 <- New.cellRendererTextNew + renderer10 <- New.cellRendererPixbufNew + col1 <- New.treeViewColumnNew + New.treeViewColumnSetTitle col1 "Module" + New.treeViewColumnSetSizing col1 TreeViewColumnAutosize + New.treeViewColumnSetResizable col1 True + New.treeViewColumnSetReorderable col1 True + New.treeViewAppendColumn treeView col1 + New.cellLayoutPackStart col1 renderer10 False + New.cellLayoutPackStart col1 renderer1 True + New.cellLayoutSetAttributes col1 renderer1 listStore + $ \row -> [ New.cellText := display $ modu $ descrModu' row] + New.cellLayoutSetAttributes col1 renderer10 listStore + $ \row -> [ + New.cellPixbufStockId := if isReexported row + then "ide_reexported" + else if isJust (mbLocation row) + then "ide_source" + else ""] + + renderer2 <- New.cellRendererTextNew + col2 <- New.treeViewColumnNew + New.treeViewColumnSetTitle col2 "Package" + New.treeViewColumnSetSizing col2 TreeViewColumnAutosize + New.treeViewColumnSetResizable col2 True + New.treeViewColumnSetReorderable col2 True + New.treeViewAppendColumn treeView col2 + New.cellLayoutPackStart col2 renderer2 True + New.cellLayoutSetAttributes col2 renderer2 listStore + $ \row -> [ New.cellText := display $ pack $ descrModu' row] + + New.treeViewSetHeadersVisible treeView True + sel <- New.treeViewGetSelection treeView + New.treeSelectionSetMode sel SelectionSingle + + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw treeView + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + + box <- vBoxNew False 2 + boxPackStart box scopebox PackNatural 0 + boxPackStart box sw PackGrow 0 + boxPackEnd box modebox PackNatural 0 + stringRef <- newIORef "" + scopeRef <- newIORef scope + modeRef <- newIORef mode + let search = IDESearch sw treeView listStore stringRef scopeRef modeRef box + notebookInsertOrdered nb box (paneName search) Nothing + widgetShowAll box + + cid1 <- treeView `afterFocusIn` + (\_ -> do reflectIDE (makeActive search) ideR session; return True) + rb1 `onToggled` (reflectIDE (scopeSelection Local) ideR session) + rb2 `onToggled` (reflectIDE (scopeSelection Package) ideR session) + rb3 `onToggled` (reflectIDE (scopeSelection System) ideR session) + mb1 `onToggled` do + widgetSetSensitivity mb4 False + active <- toggleButtonGetActive mb4 + (reflectIDE (modeSelection (Exact active)) ideR session) + mb2 `onToggled`do + widgetSetSensitivity mb4 True + active <- toggleButtonGetActive mb4 + (reflectIDE (modeSelection (Prefix active)) ideR session) + mb3 `onToggled` do + widgetSetSensitivity mb4 True + active <- toggleButtonGetActive mb4 + (reflectIDE (modeSelection (Regex active)) ideR session) + mb4 `onToggled` do + active <- toggleButtonGetActive mb4 + (reflectIDE (modeSelectionCase active) ideR session) + treeView `onButtonPress` (listViewPopup ideR session listStore treeView) + sel `New.onSelectionChanged` do + fillInfo treeView listStore ideR session + return () + return (search,[ConnectC cid1]) + addPaneAdmin buf cids panePath + liftIO $widgetGrabFocus (scrolledView buf) + +getScope :: IDESearch -> IO Scope +getScope search = readIORef (searchScopeRef search) + +getMode :: IDESearch -> IO SearchMode +getMode search = readIORef (searchModeRef search) + +scopeSelection :: Scope -> IDEAction +scopeSelection scope = do + search <- getSearch + liftIO $ writeIORef (searchScopeRef search) scope + text <- liftIO $ readIORef (searchStringRef search) + searchMetaGUI text + +modeSelection :: SearchMode -> IDEAction +modeSelection mode = do + search <- getSearch + liftIO $ writeIORef (searchModeRef search) mode + text <- liftIO $ readIORef (searchStringRef search) + searchMetaGUI text + +modeSelectionCase :: Bool -> IDEAction +modeSelectionCase caseSense = do + search <- getSearch + oldMode <- liftIO $ readIORef (searchModeRef search) + liftIO $ writeIORef (searchModeRef search) oldMode{caseSense = caseSense} + text <- liftIO $ readIORef (searchStringRef search) + searchMetaGUI text + +searchMetaGUI :: String -> IDEAction +searchMetaGUI str = do + search <- getSearch + liftIO $ writeIORef (searchStringRef search) str + scope <- liftIO $ getScope search + mode <- liftIO $ getMode search + let mode' = if length str > 2 then mode else Exact (caseSense mode) + descrs <- if null str + then return [] + else searchMeta scope str mode' + liftIO $do + New.listStoreClear (searchStore search) + mapM_ (New.listStoreAppend (searchStore search)) descrs + bringPaneToFront search + +listViewPopup :: IDERef + -> Session + -> New.ListStore Descr + -> New.TreeView + -> Event + -> IO (Bool) +listViewPopup ideR session store descrView (Button _ click _ _ _ _ button _ _) = do + if button == RightButton + then do + theMenu <- menuNew + item1 <- menuItemNewWithLabel "Go to definition" + item1 `onActivateLeaf` do + sel <- getSelectionDescr descrView store + case sel of + Just descr -> reflectIDE + (goToDefinition descr) ideR session + otherwise -> sysMessage Normal "no selection" + menuShellAppend theMenu item1 + menuPopup theMenu Nothing + widgetShowAll theMenu + return True + else if button == LeftButton && click == DoubleClick + then do sel <- getSelectionDescr descrView store + case sel of + Just descr -> reflectIDE (triggerEvent ideR (SelectIdent descr)) + ideR session >> return () + otherwise -> sysMessage Normal "no selection" + return True + else do + mbPane :: Maybe IDEInfo <- reflectIDE getPane ideR session + when (isJust mbPane) $ bringPaneToFront (fromJust mbPane) + return False +listViewPopup _ _ _ _ _ = throwIDE "listViewPopup wrong event type" + +getSelectionDescr :: New.TreeView + -> New.ListStore Descr + -> IO (Maybe Descr) +getSelectionDescr treeView listStore = do + treeSelection <- New.treeViewGetSelection treeView + paths <- New.treeSelectionGetSelectedRows treeSelection + case paths of + [a]:r -> do + val <- New.listStoreGetValue listStore a + return (Just val) + _ -> return Nothing + +fillInfo :: New.TreeView + -> New.ListStore Descr + -> IDERef + -> Session + -> IO () +fillInfo treeView listStore ideR session = do + sel <- getSelectionDescr treeView listStore + case sel of + Just descr -> reflectIDE (setInfo descr) ideR session + otherwise -> sysMessage Normal "no selection" + +setChoices :: [Descr] -> IDEAction +setChoices descrs = do + search <- getSearch + liftIO $ do + New.listStoreClear (searchStore search) + mapM_ (New.listStoreAppend (searchStore search)) descrs + bringPaneToFront search + writeIORef (searchStringRef search) "" + + diff --git a/src/IDE/Pane/SourceBuffer.hs b/src/IDE/Pane/SourceBuffer.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Pane/SourceBuffer.hs @@ -0,0 +1,1036 @@ +{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Pane.SourceBuffer +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | The source editor part of Leksah +-- +----------------------------------------------------------------------------------- + +module IDE.Pane.SourceBuffer ( + IDEBuffer(..) +, BufferState(..) + + +, allBuffers +, maybeActiveBuf +, standardSourcePanePath +, selectSourceBuf +, goToSourceDefinition +, goToDefinition + +, newTextBuffer + +, fileNew +, fileOpenThis +, fileOpen +, fileRevert +, fileClose +, fileCloseAll +, fileCloseAllButPackage +, fileSave +, editUndo +, editRedo +, editCut +, editCopy +, editPaste +, editDelete +, editSelectAll + +, editComment +, editUncomment +, editShiftRight +, editShiftLeft + +, editToCandy +, editFromCandy +, editKeystrokeCandy +, editCandy + +, markErrorInSourceBuf +, inBufContext' +, inBufContext + +, align +) 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.Map (Map) +import Data.List +import Data.Maybe +import Data.Typeable +import System.Time +--import GHC.Conc +--import Debug.Trace + +import IDE.Core.State +import Control.Event +import IDE.FileUtils +import IDE.SourceCandy +import qualified System.IO.UTF8 as UTF8 +import Graphics.UI.Gtk.Gdk.Enums (Modifier(..)) +import qualified Graphics.UI.Gtk.Gdk.Events as G (Event(..)) + +-- +-- | A text editor pane description +-- +data IDEBuffer = IDEBuffer { + fileName :: Maybe FilePath +, bufferName :: String +, addedIndex :: Int +, sourceView :: SourceView +, scrolledWindow :: ScrolledWindow +, modTime :: Maybe (ClockTime) +, language :: Maybe String +} deriving (Typeable) + +data BufferState = BufferState FilePath Int + deriving(Eq,Ord,Read,Show,Typeable) + +instance IDEObject IDEBuffer +instance Pane IDEBuffer IDEM + where + primPaneName = bufferName + getAddedIndex = addedIndex + getTopWidget = castToWidget . scrolledWindow + paneId b = case fileName b of + Just s -> s + Nothing -> "?" ++ bufferName b + makeActive buf = do + (PaneC pane) <- paneFromName (paneName buf) + let mbActbuf = cast pane + if isJust mbActbuf + then do + let actbuf = fromJust mbActbuf + ideR <- ask + sbLC <- getStatusbarLC + sbIO <- getStatusbarIO + infos <- readIDE accessibleInfo + let sv = sourceView actbuf + (cids) <- reifyIDE $ \ideR session -> do + gtkBuf <- textViewGetBuffer sv + bringPaneToFront actbuf + writeCursorPositionInStatusbar sv sbLC + writeOverwriteInStatusbar sv sbIO + id1 <- gtkBuf `afterModifiedChanged` reflectIDE (markLabelAsChanged) ideR session + id2 <- sv `afterMoveCursor` + (\_ _ _ -> writeCursorPositionInStatusbar sv sbLC) + id3 <- gtkBuf `afterEndUserAction` writeCursorPositionInStatusbar sv sbLC + sv `widgetAddEvents` [ButtonReleaseMask] + id5 <- sv `onButtonRelease` + (\ e -> do + writeCursorPositionInStatusbar sv sbLC + when (controlIsPressed e) $ showInfo sv ideR session + return False) + id6 <- sv `afterToggleOverwrite` writeOverwriteInStatusbar sv sbIO + return [ConnectC id2,ConnectC id6,ConnectC id1,ConnectC id3] + activatePane actbuf cids + liftIO $ + idleAdd (do + widgetQueueDraw sv -- Patch for problem on one machine ## + return False) priorityDefaultIdle + modifyIDE_ (\ide -> return (ide{lastActiveBufferPane = Just (paneName buf)})) + triggerEvent ideR (Sensitivity [(SensitivityEditor, True)]) + checkModTime actbuf + else return () + close pane = do makeActive pane + fileClose + return () + +controlIsPressed :: G.Event -> Bool +controlIsPressed (G.Button _ _ _ _ _ mods _ _ _) | Control `elem` mods = True +controlIsPressed _ = False + +instance RecoverablePane IDEBuffer BufferState IDEM where + saveState p = do buf <- liftIO $ textViewGetBuffer (sourceView p) + ins <- liftIO $ textBufferGetInsert buf + iter <- liftIO $ textBufferGetIterAtMark buf ins + offset <- liftIO $ textIterGetOffset iter + case fileName p of + Nothing -> return Nothing + Just fn -> return (Just (BufferState fn offset)) + recoverState pp (BufferState n i) = do + exists <- liftIO $doesFileExist n + when exists $ do + buf <- newTextBuffer pp (takeFileName n) (Just n) + liftIO $ do + gtkBuf <- textViewGetBuffer (sourceView buf) + iter <- textBufferGetIterAtOffset gtkBuf i + textBufferPlaceCursor gtkBuf iter + mark <- textBufferGetInsert gtkBuf + idleAdd (do + textViewScrollToMark (sourceView buf) mark 0.0 (Just (0.3,0.3)) + return False) priorityDefaultIdle + return () + +selectSourceBuf :: FilePath -> IDEM (Maybe IDEBuffer) +selectSourceBuf fp = do + fpc <- liftIO $ 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 (Just hdb) + otherwise -> do + fe <- liftIO $ doesFileExist fpc + if fe + then do + path <- standardSourcePanePath + nbuf <- newTextBuffer path (takeFileName fpc) (Just fpc) + return (Just nbuf) + else return Nothing + +goToDefinition :: Descr -> IDEAction +goToDefinition idDescr = do + mbAccesibleInfo <- readIDE accessibleInfo + mbCurrentInfo <- readIDE currentInfo + if isJust mbAccesibleInfo && isJust mbCurrentInfo + then do + let packageId = pack $ descrModu 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 == descrModu idDescr) + (exposedModulesPD pack) of + (mod : tl) -> if isJust (mbSourcePathMD mod) + then goToSourceDefinition + (fromJust $ mbSourcePathMD mod) + (mbLocation idDescr) + else return () + [] -> do ideMessage Normal "no module" + Nothing -> do ideMessage Normal "no package" + else ideMessage Normal "no infos" + +goToSourceDefinition :: FilePath -> Maybe Location -> IDEAction +goToSourceDefinition fp mbLocation = do + mbBuf <- selectSourceBuf fp + when (isJust mbBuf && 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 + -- ### we had a problem before using this idleAdd thing + idleAdd (do + textViewScrollToIter (sourceView buf) iter 0.0 (Just (0.3,0.3)) + return False) priorityDefaultIdle + return () + + +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 + idleAdd (do + textViewScrollToMark (sourceView buf) mark 0.3 Nothing + return False) priorityDefaultIdle + return () + +allBuffers :: IDEM [IDEBuffer] +allBuffers = getPanes + +maybeActiveBuf :: IDEM (Maybe IDEBuffer) +maybeActiveBuf = do + mbPane <- readIDE lastActiveBufferPane + case mbPane of + Nothing -> return Nothing + Just paneName -> do + (PaneC pane) <- paneFromName paneName + let mbActbuf = cast pane + return mbActbuf + +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 + 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) <- reifyIDE $ \ideR session -> do + lm <- sourceLanguageManagerNew + (mbLanguage, mbSLang) <- sourceLanguageForFilename lm mbfn + + -- create a new SourceBuffer object + buffer <- case mbSLang of + Just sLang -> sourceBufferNewWithLanguage sLang + Nothing -> sourceBufferNew Nothing + sourceBufferSetMaxUndoLevels buffer (-1) + 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 <- UTF8.readFile fn + mt <- getModificationTime fn + return (fc,Just mt) + Nothing -> return ("\n\n\n\n\n",Nothing) + sourceBufferBeginNotUndoableAction buffer + textBufferSetText buffer fileContents + when bs $ transformToCandy ct (castToTextBuffer buffer) + sourceBufferEndNotUndoableAction buffer + textBufferSetModified buffer False + siter <- textBufferGetStartIter buffer + textBufferPlaceCursor buffer siter + iter <- textBufferGetEndIter buffer + textBufferCreateMark buffer (Just "end") iter True + + -- create a new SourceView Widget + sv <- sourceViewNewWithBuffer buffer + set sv [sourceViewHighlightCurrentLine := True] + 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 + set sv [sourceViewShowRightMargin := True] + sourceViewSetRightMarginPosition sv (fromIntegral n) + Nothing -> set sv [sourceViewShowRightMargin := False] + sourceViewSetInsertSpacesInsteadOfTabs sv True + sourceViewSetIndentWidth sv (tabWidth prefs) + sourceViewSetTabWidth sv (tabWidth prefs) + sourceViewSetIndentOnTab sv True + sourceViewSetAutoIndent sv True + sourceViewSetSmartHomeEnd sv SourceSmartHomeEndBefore + case sourceStyle prefs of + Nothing -> return () + Just str -> do + styleManager <- sourceStyleSchemeManagerNew + ids <- sourceStyleSchemeManagerGetSchemeIds styleManager + when (elem str ids) $ do + scheme <- sourceStyleSchemeManagerGetScheme styleManager str + sourceBufferSetStyleScheme buffer scheme + + -- 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 mbLanguage + notebookInsertOrdered nb sw rbn Nothing + -- events + cid <- sv `afterFocusIn` + (\_ -> do reflectIDE (makeActive buf) ideR session; return False) + return (buf,[cid]) + addPaneAdmin buf (map ConnectC cids) panePath + liftIO $widgetShowAll (scrolledWindow buf) + liftIO $widgetGrabFocus (sourceView buf) + return buf + +checkModTime :: IDEBuffer -> IDEAction +checkModTime buf = do + isShuttingDown' <- readIDE isShuttingDown + if isShuttingDown' + then return () + else do + panes <- readIDE panes + let name = paneName buf + case fileName buf of + Just fn -> do + exists <- liftIO $doesFileExist fn + if exists + then do + nmt <- liftIO $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 <- liftIO $messageDialogNew + Nothing [] + MessageQuestion + ButtonsYesNo + ("File has changed on disk " ++ name ++ " Revert?") + resp <- liftIO $dialogRun md + case resp of + ResponseYes -> do + revert buf + liftIO $widgetHide md + ResponseNo -> do + let newPanes = Map.adjust (\(PaneC b) -> + let mbActbuf = cast b + in if isJust mbActbuf + then PaneC ((fromJust mbActbuf) + {modTime = (Just nmt)}) + else PaneC b) + name panes + modifyIDE_ (\ide -> return (ide{panes = newPanes})) + liftIO $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 <- liftIO $getModificationTime fn + let newPanes = Map.adjust (\(PaneC b) -> + let mbActbuf = cast b + in if isJust mbActbuf + then PaneC ((fromJust mbActbuf){modTime = (Just nmt)}) + else PaneC 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 <- liftIO $do + buffer' <- textViewGetBuffer (sourceView buf) + let buffer = castToSourceBuffer buffer' + fc <- UTF8.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 (\(PaneC b) -> + let mbActbuf = cast b + in if isJust mbActbuf + then PaneC ((fromJust mbActbuf){modTime = (Just mt)}) + else (PaneC 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 -> Session -> IO () +showInfo sv ideR session = do + buf <- textViewGetBuffer sv + (l,r) <- textBufferGetSelectionBounds buf + symbol <- textBufferGetText buf l r True + reflectIDE (triggerEvent ideR (SelectInfo symbol)) ideR session + 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 -> liftIO $do + gtkbuf <- textViewGetBuffer (sourceView buf) + modified <- textBufferGetModified gtkbuf + mbText <- notebookGetTabLabelText nb (scrolledWindow buf) + label <- labelNew Nothing + labelSetUseMarkup label True + case mbText of + Nothing -> return () + Just text -> labelSetMarkup label + (if modified + then "" ++ text ++ "" + else text) + notebookSetTabLabel nb (scrolledWindow buf) label + +inBufContext' :: alpha -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM alpha ) -> IDEM alpha +inBufContext' def f = do + mbBuf <- maybeActiveBuf + case mbBuf of + Nothing -> return def + Just ideBuf -> do + (pane,_) <- guiPropertiesFromName (paneName ideBuf) + nb <- getNotebook pane + mbI <- liftIO $notebookPageNum nb (scrolledWindow ideBuf) + case mbI of + Nothing -> liftIO $ do + sysMessage Normal $ bufferName ideBuf ++ " notebook page not found: unexpected" + return def + Just i -> do + gtkbuf <- liftIO $ 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 -> liftIO $ 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,connects) + <- guiPropertiesFromName (paneName currentBuffer) + mbnbufsPm <- do + let mbfn = fileName currentBuffer + mbpage <- liftIO $notebookGetNthPage nb i + case mbpage of + Nothing -> throwIDE "fileSave: Page not found" + Just page -> + if isJust mbfn && query == False + then do checkModTime currentBuffer + liftIO $fileSave' (forceLineEnds prefs) (removeTBlanks prefs) currentBuffer bs candy $fromJust mbfn + setModTime currentBuffer + return Nothing + else reifyIDE $ \ideR session -> 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) (removeTBlanks 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 + signalDisconnectAll connects + cid1 <- (sourceView currentBuffer) `afterFocusIn` + (\_ -> do reflectIDE (makeActive newBuffer) ideR session + return True) + let paneMap1 = Map.delete rbn paneMap + let newPaneMap = Map.insert rbn + (panePath,[ConnectC 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 -> Bool -> IDEBuffer -> Bool -> CandyTable -> FilePath -> IO() + fileSave' forceLineEnds removeTBlanks ideBuf bs ct fn = do + buf <- textViewGetBuffer $ sourceView ideBuf + text <- getCandylessText ct buf + let text' = if removeTBlanks + then unlines $map removeTrailingBlanks $lines text + else text + succ <- catch (do UTF8.writeFile fn text'; return True) + (\e -> do + sysMessage Normal (show e) + return False) + textBufferSetModified buf (not succ) + 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 + window <- readIDE window + bufs <- readIDE panes + paneMap <- readIDE paneMap + cancel <- reifyIDE $ \ideR session -> 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 + reflectIDE (fileSave False) ideR session + return False + ResponseCancel -> return True + ResponseNo -> return False + _ -> return False + else return False + if cancel + then return False + else do + deactivatePane + removePaneAdmin currentBuffer + liftIO $ do + notebookRemovePage nb i + widgetDestroy (getTopWidget 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 <- liftIO $notebookPageNum nb (scrolledWindow buf) + case mbI of + Nothing -> throwIDE "notebook page not found: unexpected" + Just i -> do + gtkbuf <- liftIO $ textViewGetBuffer (sourceView buf) + let dir = dropFileName $ cabalFile activePack + when (isJust (fileName buf)) $ do + modified <- liftIO $ 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 <- liftIO $ 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 -> fileOpenThis fp + + +fileOpenThis :: FilePath -> IDEAction +fileOpenThis fp = do + prefs <- readIDE prefs + fpc <- liftIO $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 <- liftIO $messageDialogNew + Nothing [] + MessageQuestion + ButtonsYesNo + ("Buffer already open. " ++ + "Make active instead of opening a second time?") + resp <- liftIO $dialogRun md + liftIO $ widgetDestroy md + case resp of + ResponseNo -> reallyOpen prefs fpc + _ -> makeActive hdb + [] -> reallyOpen prefs fpc + where + reallyOpen prefs fpc = do + pp <- standardSourcePanePath + newTextBuffer pp (takeFileName fpc) (Just fpc) + return () + +editUndo :: IDEAction +editUndo = inBufContext () $ \_ gtkbuf _ _ -> + let sb = castToSourceBuffer gtkbuf in + do canUndo <- sourceBufferGetCanUndo sb + if canUndo + then sourceBufferUndo sb + else return () + +editRedo :: IDEAction +editRedo = inBufContext () $ \_ gtkbuf _ _ -> + let sb = castToSourceBuffer gtkbuf in + do canRedo <- sourceBufferGetCanRedo 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 +editCut = inBufContext () $ \_ gtkbuf _ _ -> do + cb <- atomNew "GDK_SELECTION_CLIPBOARD" + clip <- clipboardGet cb + textBufferCutClipboard gtkbuf clip True + +editCopy :: IDEAction +editCopy = inBufContext () $ \_ gtkbuf _ _ -> do + cb <- atomNew "GDK_SELECTION_CLIPBOARD" + clip <- clipboardGet cb + textBufferCopyClipboard gtkbuf clip + +editPaste :: IDEAction +editPaste = inBufContext () $ \_ gtkbuf _ _ -> do + cb <- atomNew "GDK_SELECTION_CLIPBOARD" + mark <- textBufferGetInsert gtkbuf + iter <- textBufferGetIterAtMark gtkbuf mark + clip <- clipboardGet cb + textBufferPasteClipboard gtkbuf clip iter True + +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 _ -> liftIO $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 :: IDEAction +editCandy = do + ct <- readIDE candy + buffers <- allBuffers + gtkbufs <- liftIO $mapM (\ b -> textViewGetBuffer (sourceView b)) buffers + bs <- getCandyState + if bs + then liftIO $mapM_ (transformToCandy ct) gtkbufs + else liftIO $mapM_ (transformFromCandy ct) gtkbufs + +alignChar :: Char -> IDEAction +alignChar char = do + positions <- positionsOfChar + let alignTo = foldl' max 0 (catMaybes (map snd positions)) + if (alignTo > 0) + then alignChar (Map.fromList positions) alignTo + else return () + where + positionsOfChar :: IDEM ([(Int, Maybe Int)]) + positionsOfChar = doForSelectedLines [] $ \gtkbuf iter lineNr -> do + textIterSetLine iter lineNr + iter2 <- textIterCopy iter + textIterForwardToLineEnd iter2 + line <- textIterGetText iter iter2 + return (lineNr, elemIndex char line) + alignChar :: Map Int (Maybe Int) -> Int -> IDEM () + alignChar positions alignTo = do + doForSelectedLines [] $ \gtkbuf iter lineNr -> do + case lineNr `Map.lookup` positions of + Just (Just n) -> do + textIterSetLine iter lineNr + textIterForwardChars iter n + textBufferInsert gtkbuf iter (replicate (alignTo - n) ' ') + _ -> return () + return () + +transChar :: Char -> Char +transChar ':' = toEnum 0x2237 --PROPORTION +transChar '>' = toEnum 0x2192 --RIGHTWARDS ARROW +transChar '<' = toEnum (toEnum 0x2190) --LEFTWARDS ARROW +transChar c = c + +align :: Char -> IDEAction +align = alignChar . transChar + +-- +--alignEqual :: IDEAction +--alignEqual = alignChar '=' +-- +--alignRightArrow :: IDEAction +--alignRightArrow = alignChar (toEnum 0x2192) --RIGHTWARDS ARROW +-- +--alignLeftArrow :: IDEAction +--alignLeftArrow = alignChar (toEnum 0x2190) --LEFTWARDS ARROW +-- +--alignTypeOf :: IDEAction +--alignTypeOf = alignChar (toEnum 0x2237) --PROPORTION + +--guessLanguage :: Maybe FilePath -> Maybe String +--guessLanguage Nothing = Just "Haskell" +--guessLanguage (Just fp) = +-- case takeExtension fp of +-- ".c" -> Just "C" +-- ".hs" -> Just "Haskell" +-- ".chs" -> Just "Haskell" +-- ".hsc" -> Just "Haskell" +-- ".lhs" -> Just "Literate Haskell" +-- ".haddock" -> Just "Haddock" +-- _ -> Nothing + +{-- +sourceLanguageForFilename :: SourceLanguageManager -> Maybe String -> IO (Maybe String, Maybe SourceLanguage) +sourceLanguageForFilename lm Nothing = + liftM (\l -> (Just "haskell", Just l)) () +sourceLanguageForFilename lm (Just filename) = + let extension = takeExtension filename in do + ids <- sourceLanguageManagerGetLanguageIds lm + relevant <- filterM (\id -> do + lang <- sourceLanguageManagerGetLanguage lm id + globs <- sourceLanguageGetGlobs lang + return (match extension globs)) ids + case relevant of + [] -> return (Nothing,Nothing) + hd:_ -> liftM (\l -> (Just hd, Just l)) (sourceLanguageManagerGetLanguage lm hd) + where + match :: String -> [String] -> Bool + match ext = not . null . filter (== ext) . map (drop 1) +--} + + +sourceLanguageForFilename :: SourceLanguageManager -> Maybe String -> IO (Maybe String, Maybe SourceLanguage) +sourceLanguageForFilename lm Nothing = do + mbLang <- sourceLanguageManagerGuessLanguage lm Nothing (Just "text/x-haskell") + case mbLang of + Nothing -> return (Nothing,Nothing) + Just lang -> do + name <- sourceLanguageGetName lang + return (Just name, Just lang) + +sourceLanguageForFilename lm (Just filename) = do + mbLang <- sourceLanguageManagerGuessLanguage lm (Just filename) Nothing + case mbLang of + Nothing -> return (Nothing,Nothing) + Just lang -> do + name <- sourceLanguageGetName lang + return (Just name, Just lang) + + + + + diff --git a/src/IDE/Preferences.hs b/src/IDE/Preferences.hs deleted file mode 100644 --- a/src/IDE/Preferences.hs +++ /dev/null @@ -1,350 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : IDE.Preferences --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- --- | Module for saving, restoring and editing preferences --- ---------------------------------------------------------------------------------- - - -module IDE.Preferences ( - readPrefs -, writePrefs -, defaultPrefs -, prefsDescription -, editPrefs -) where - -import Graphics.UI.Gtk.SourceView -import Graphics.UI.Gtk -import Control.Monad.Reader -import qualified Text.ParserCombinators.Parsec as P -import Data.List -import qualified Text.PrettyPrint.HughesPJ as PP -import Distribution.Package -import Data.IORef - -import IDE.Core.State -import IDE.Framework.ViewFrame -import IDE.Framework.SimpleEditors -import IDE.Framework.CompositeEditors -import IDE.Framework.Parameters -import IDE.Framework.MakeEditor hiding (fieldEditor,parameters) -import IDE.DescriptionPP -import IDE.PrinterParser hiding (fieldParser,parameters) -import IDE.SourceEditor -import IDE.Log -import IDE.SpecialEditors -import IDE.Utils.Default -import IDE.Utils.File - - -prefsDescription :: [(String,[FieldDescriptionPP Prefs])] -prefsDescription = [ - ("Editor", [ - mkFieldPP - (paraName <<<- ParaName "Show line numbers" - $ paraSynopsis <<<- ParaSynopsis "(True/False)" $ emptyParams) - (PP.text . show) - boolParser - showLineNumbers - (\ b a -> a{showLineNumbers = b}) - boolEditor - (\b -> do - buffers <- allBuffers - mapM_ (\buf -> lift$sourceViewSetShowLineNumbers (sourceView buf) b) buffers) - , mkFieldPP - (paraName <<<- ParaName "TextView Font" $ emptyParams) - (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s)) - (do str <- stringParser - return (if null str then Nothing else Just (str))) - textviewFont - (\ b a -> a{textviewFont = b}) - fontEditor - (\mbs -> do - buffers <- allBuffers - fdesc <- lift $fontDescriptionFromString (case mbs of Just str -> str; Nothing -> "") - lift $mapM_ (\buf -> widgetModifyFont (castToWidget $sourceView buf) (Just fdesc)) buffers) - , mkFieldPP - (paraName <<<- ParaName "Right margin" - $ paraSynopsis <<<- ParaSynopsis "Size or 0 for no right margin" - $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams) - (\a -> (PP.text . show) (case a of Nothing -> 0; Just i -> i)) - (do i <- intParser - return (if i == 0 then Nothing else Just i)) - rightMargin - (\b a -> a{rightMargin = b}) - (maybeEditor (intEditor (1.0, 200.0, 5.0), paraName <<<- ParaName "Position" - $ emptyParams) - True "Show it ?") - (\b -> do - buffers <- allBuffers - mapM_ (\buf -> case b of - Just n -> do - lift $sourceViewSetMargin (sourceView buf) n - lift $sourceViewSetShowMargin (sourceView buf) True - Nothing -> lift $sourceViewSetShowMargin (sourceView buf) False) - buffers) - , mkFieldPP - (paraName <<<- ParaName "Tab width" $ emptyParams) - (PP.text . show) - intParser - tabWidth - (\b a -> a{tabWidth = b}) - (intEditor (1.0, 20.0, 1.0)) - (\i -> do - buffers <- allBuffers - mapM_ (\buf -> lift $sourceViewSetTabsWidth (sourceView buf) i) buffers) - , mkFieldPP - (paraName <<<- ParaName "Use standard line ends even on windows" $ emptyParams) - (PP.text . show) - boolParser - forceLineEnds - (\b a -> a{forceLineEnds = b}) - boolEditor - (\i -> return ()) - , mkFieldPP - (paraName <<<- ParaName "Source candy" - $ paraSynopsis <<<- ParaSynopsis - "Empty for do not use or the name of a candy file in a config dir" - $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams) - (\a -> PP.text (case a of Nothing -> ""; Just s -> s)) - (do id <- identifier - return (if null id then Nothing else Just (id))) - sourceCandy (\b a -> a{sourceCandy = b}) - (maybeEditor (stringEditor, paraName <<<- ParaName "Candy specification" - $ emptyParams) - True "Use it ?") - (\cs -> case cs of - Nothing -> do - setCandyState False - editCandy - Just name -> do - setCandyState True - editCandy) - , mkFieldPP - (paraName <<<- ParaName "Name of the keymap" - $ paraSynopsis <<<- ParaSynopsis - "The name of a keymap file in a config dir" - $ paraDirection <<<- ParaDirection Horizontal $ emptyParams) - PP.text - identifier - keymapName - (\b a -> a{keymapName = b}) - stringEditor - (\ a -> return ()) - ]), - ("Other", [ - mkFieldPP - (paraName <<<- ParaName "LogView Font" $ emptyParams) - (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s)) - (do str <- stringParser - return (if null str then Nothing else Just (str))) - logviewFont - (\ b a -> a{logviewFont = b}) - fontEditor - (\mbs -> do - buffer <- getLog - fdesc <- lift $fontDescriptionFromString (case mbs of Just str -> str; Nothing -> "") - lift $widgetModifyFont (castToWidget $textView buffer) (Just fdesc)) - , mkFieldPP - (paraName <<<- ParaName "Window default size" - $ paraSynopsis <<<- ParaSynopsis - "Default size of the main ide window specified as pair (int,int)" - $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams) - (PP.text.show) - (pairParser intParser) - defaultSize (\(c,d) a -> a{defaultSize = (c,d)}) - (pairEditor ((intEditor (0.0, 3000.0, 25.0)), - paraName <<<- ParaName "X" $ emptyParams) - ((intEditor (0.0, 3000.0, 25.0)), - paraName <<<- ParaName "Y" $ emptyParams)) - (\a -> return ()) - , mkFieldPP - (paraName <<<- ParaName "Browser" $ emptyParams) - (PP.text . show) - stringParser - browser - (\b a -> a{browser = b}) - stringEditor - (\i -> return ()) - , mkFieldPP - (paraName <<<- ParaName "Standard source editor path" $ emptyParams) - (PP.text . show) - readParser - sourcePanePath - (\b a -> a{sourcePanePath = b}) - panePathEditor - (\i -> return ()) - , mkFieldPP - (paraName <<<- ParaName - "Paths under which haskell sources for packages may be found" $ emptyParams) - (PP.text . show) - readParser - sourceDirectories - (\b a -> a{sourceDirectories = b}) - (filesEditor Nothing FileChooserActionSelectFolder "Select folder") - (\i -> return ()) - , mkFieldPP - (paraName <<<- ParaName - "Packages which are excluded from the modules pane" $ emptyParams) - (PP.text . show) - readParser - packageBlacklist - (\b a -> a{packageBlacklist = b}) - dependenciesEditor - (\i -> return ()) - ])] - -instance Default PackageIdentifier where - getDefault = case toPackageIdentifier "unknown-0" of - Nothing -> throwIDE "Preferences.getDefault: Can't parse Package Identifier" - Just it -> it - -defaultPrefs = Prefs { - showLineNumbers = True - , rightMargin = Just 100 - , tabWidth = 4 - , sourceCandy = Just("Default") - , keymapName = "Default" - , forceLineEnds = True - , textviewFont = Nothing - , logviewFont = Nothing - , defaultSize = (1024,800) - , browser = "firefox" - , sourcePanePath = LeftTop - , logPanePath = RightBottom - , infoPanePath = RightBottom - , modulesPanePath = RightTop - , controlPanePath = RightTop - , sourceDirectories = ["C:/ghc","C:/cygwin/home/Nicklisch-Franken/collect"] - , packageBlacklist = [] - } - --- ------------------------------------------------------------ --- * Parsing --- ------------------------------------------------------------ - -readPrefs :: FilePath -> IO Prefs -readPrefs fn = do - res <- P.parseFromFile (prefsParser defaultPrefs (concatMap snd prefsDescription)) fn - case res of - Left pe -> throwIDE $"Error reading prefs file " ++ show fn ++ " " ++ show pe - Right r -> return r - -prefsParser :: a -> [FieldDescriptionPP a] -> P.CharParser () a -prefsParser def descriptions = - let parsersF = map fieldParser descriptions in do - whiteSpace - res <- applyFieldParsers def parsersF - return res - P. "prefs parser" - --- ------------------------------------------------------------ --- * Printing --- ------------------------------------------------------------ - -writePrefs :: FilePath -> Prefs -> IO () -writePrefs fpath prefs = writeFile fpath (showPrefs prefs (concatMap snd prefsDescription)) - -showPrefs :: a -> [FieldDescriptionPP a] -> String -showPrefs prefs prefsDesc = PP.render $ - foldl (\ doc (FDPP _ printer _ _ _) -> doc PP.$+$ printer prefs) PP.empty prefsDesc - - --- ------------------------------------------------------------ --- * Editing --- ------------------------------------------------------------ - -editPrefs :: IDEAction -editPrefs = do - ideR <- ask - p <- readIDE prefs - lift $editPrefs' p prefsDescription ideR - - -editPrefs' :: Prefs -> [(String,[FieldDescriptionPP Prefs])] -> IDERef -> IO () -editPrefs' prefs prefsDesc ideR = do - let flatPrefsDesc = concatMap snd prefsDesc - lastAppliedPrefsRef <- newIORef prefs - dialog <- windowNew - vb <- vBoxNew False 0 - bb <- hButtonBoxNew - apply <- buttonNewFromStock "gtk-apply" - restore <- buttonNewFromStock "Restore" - ok <- buttonNewFromStock "gtk-ok" - cancel <- buttonNewFromStock "gtk-cancel" - boxPackStart bb apply PackNatural 0 - boxPackStart bb restore PackNatural 0 - boxPackStart bb ok PackNatural 0 - boxPackStart bb cancel PackNatural 0 - nb <- newNotebook - notebookSetTabPos nb PosTop - res <- mapM - (\ (tabLabel, partPrefsDesc) -> do - resList <- mapM (\ fd -> (fieldEditor fd) prefs) partPrefsDesc - let (widgetsP, setInjsP, getExtsP,notifiersP) = unzip4 resList - nbbox <- vBoxNew False 0 - mapM_ (\ w -> boxPackStart nbbox w PackNatural 0) widgetsP - sw <- scrolledWindowNew Nothing Nothing - scrolledWindowAddWithViewport sw nbbox - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - notebookAppendPage nb sw tabLabel - return (widgetsP, setInjsP, getExtsP, notifiersP)) - prefsDesc - let (widgets, setInjs, getExts, notifiers) = - foldl (\ (w,i,e,n) (w2,i2,e2,n2) -> (w ++ w2, i ++ i2, e ++ e2, n ++ n2)) ([],[],[],[]) res - let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of - Just s -> s - Nothing -> "Unnamed") flatPrefsDesc - ok `onClicked` (do - mbNewPrefs <- extractAndValidate prefs getExts fieldNames - case mbNewPrefs of - Nothing -> return () - Just newPrefs -> do - lastAppliedPrefs <- readIORef lastAppliedPrefsRef - mapM_ (\ (FDPP _ _ _ _ applyF) -> runReaderT (applyF newPrefs lastAppliedPrefs) ideR) flatPrefsDesc - fp <- getConfigFilePathForSave "Default.prefs" - writePrefs fp newPrefs - runReaderT (modifyIDE_ (\ide -> return (ide{prefs = newPrefs}))) ideR - widgetDestroy dialog - mainQuit) - apply `onClicked` (do - mbNewPrefs <- extractAndValidate prefs getExts fieldNames - case mbNewPrefs of - Nothing -> return () - Just newPrefs -> do - lastAppliedPrefs <- readIORef lastAppliedPrefsRef - mapM_ (\ (FDPP _ _ _ _ applyF) -> runReaderT (applyF newPrefs lastAppliedPrefs) ideR) flatPrefsDesc - writeIORef lastAppliedPrefsRef newPrefs) - restore `onClicked` (do - lastAppliedPrefs <- readIORef lastAppliedPrefsRef - mapM_ (\ (FDPP _ _ _ _ applyF) -> runReaderT (applyF prefs lastAppliedPrefs) ideR) flatPrefsDesc - mapM_ (\ setInj -> setInj prefs) setInjs - writeIORef lastAppliedPrefsRef prefs) - cancel `onClicked` (do - lastAppliedPrefs <- readIORef lastAppliedPrefsRef - mapM_ (\ (FDPP _ _ _ _ applyF) -> runReaderT (applyF prefs lastAppliedPrefs) ideR) flatPrefsDesc - widgetDestroy dialog - mainQuit) - dialog `onDelete` (\_ -> do - widgetDestroy dialog - mainQuit - return True) - boxPackStart vb nb PackGrow 7 - boxPackEnd vb bb PackNatural 7 - containerAdd dialog vb - widgetSetSizeRequest dialog 500 700 - widgetShowAll dialog - mainGUI - return () - - - diff --git a/src/IDE/PrinterParser.hs b/src/IDE/PrinterParser.hs --- a/src/IDE/PrinterParser.hs +++ b/src/IDE/PrinterParser.hs @@ -28,14 +28,15 @@ ) 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 +import Graphics.UI.Editor.Parameters +import Graphics.UI.Editor.Basics +import System.IO.Unsafe (unsafePerformIO) +import Control.Monad (liftM) type Printer beta = beta -> PP.Doc @@ -79,13 +80,13 @@ applyFieldParsers :: a -> [a -> CharParser () a] -> CharParser () a applyFieldParsers prefs parseF = do + eof + return (prefs) + <|> do let parsers = map (\a -> a prefs) parseF newprefs <- choice parsers whiteSpace applyFieldParsers newprefs parseF - <|> do - eof - return (prefs) "field parser" boolParser :: CharParser () Bool @@ -100,7 +101,13 @@ readParser :: Read a => CharParser () a readParser = do str <- many (noneOf ['\n']) - return (read str) + if null str + then unexpected "read parser on empty string" + else case unsafePerformIO + (catch (liftM Just (readIO str)) + (\e -> return Nothing)) of + Nothing -> unexpected $ "read parser no parse " ++ str + Just r -> return r "read parser" pairParser :: CharParser () alpha -> CharParser () (alpha,alpha) diff --git a/src/IDE/RecoverPanes.hs b/src/IDE/RecoverPanes.hs deleted file mode 100644 --- a/src/IDE/RecoverPanes.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- --- Module : IDE.RecoverPanes --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | --- -------------------------------------------------------------------------------- -module IDE.RecoverPanes ( - paneStateToIDEState -) where - -import IDE.Core.State -import IDE.Log() -import IDE.SourceEditor() -import IDE.ModulesPane() -import IDE.InfoPane() -import IDE.ToolbarPane() -import IDE.FindPane() -import IDE.ReplacePane() - -paneStateToIDEState :: PaneState -> IDEState -paneStateToIDEState (BufferSt st) = StateC st -paneStateToIDEState (LogSt st) = StateC st -paneStateToIDEState (InfoSt st) = StateC st -paneStateToIDEState (ModulesSt st) = StateC st -paneStateToIDEState (CallersSt st) = StateC st -paneStateToIDEState (ToolbarSt st) = StateC st -paneStateToIDEState (FindSt st) = StateC st -paneStateToIDEState (ReplaceSt st) = StateC st diff --git a/src/IDE/ReplacePane.hs b/src/IDE/ReplacePane.hs deleted file mode 100644 --- a/src/IDE/ReplacePane.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- --- Module : IDE.ReplacePane --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | The pane of ide for replacing text in a text buffer --- -------------------------------------------------------------------------------- - -module IDE.ReplacePane ( - ReplaceAction(..) -) where - -import Graphics.UI.Gtk hiding (get) -import Data.Maybe -import Control.Monad.Reader -import Data.List -import Data.Char(toUpper) - -import IDE.Core.State -import IDE.Framework.ViewFrame -import IDE.Framework.MakeEditor -import IDE.SourceEditor -import IDE.Framework.Parameters -import IDE.Framework.SimpleEditors -import IDE.Framework.EditorBasics -import IDE.FindPane - - -------------------------------------------------------------------------------- --- --- * Interface --- - --- --- | The Replace Pane --- - -class ReplaceAction alpha where - doReplace :: alpha - -instance ReplaceAction IDEAction where - doReplace = doReplace' - -instance IDEObject IDEReplace - -instance CastablePane IDEReplace where - casting _ = ReplaceCasting - downCast _ (PaneC a) = case casting a of - ReplaceCasting -> Just a - _ -> Nothing - - -instance Recoverable ReplaceState where - toPaneState a = ReplaceSt a - -instance Pane IDEReplace - where - primPaneName _ = "Replace" - getAddedIndex _ = 0 - getTopWidget = castToWidget . replaceBox - paneId b = "*Replace" - makeActive p = throwIDE "don't activate replace bar" - close pane = do - (panePath,_) <- guiPropertiesFromName (paneName pane) - nb <- getNotebook panePath - mbI <- lift $notebookPageNum nb (getTopWidget pane) - case mbI of - Nothing -> lift $ do - sysMessage Normal "notebook page not found: unexpected" - return () - Just i -> do - lift $notebookRemovePage nb i - removePaneAdmin pane - -instance RecoverablePane IDEReplace ReplaceState where - saveState p = do - mbFind <- getPane ReplaceCasting - case mbFind of - Nothing -> return Nothing - Just p -> return Nothing - --lift $ do - --return (Just (StateC ReplaceState)) - recoverState pp st = do - nb <- getNotebook pp - initReplace pp nb st - - -------------------------------------------------------------------------------- --- --- * Implementation --- - -emptyReplaceState = ReplaceState "" "" False False False - -doReplace' :: IDEAction -doReplace' = do - replace <- getReplace - lift $ bringPaneToFront replace - lift $ widgetGrabFocus (replaceBox replace) - -getReplace :: IDEM IDEReplace -getReplace = do - mbReplace <- getPane ReplaceCasting - case mbReplace of - Nothing -> do - prefs <- readIDE prefs - layout <- readIDE layout - let pp = getStandardPanePath (controlPanePath prefs) layout - nb <- getNotebook pp - initReplace pp nb emptyReplaceState - mbReplace <- getPane ReplaceCasting - case mbReplace of - Nothing -> throwIDE "Can't init replace pane" - Just m -> return m - Just m -> return m - -initReplace :: PanePath -> Notebook -> ReplaceState -> IDEAction -initReplace panePath nb replace = do - ideR <- ask - panes <- readIDE panes - paneMap <- readIDE paneMap - prefs <- readIDE prefs - currentInfo <- readIDE currentInfo - (buf,cids) <- lift $ do - vb <- vBoxNew False 0 - hb <- hBoxNew False 0 - bb <- hButtonBoxNew - - replAll <- buttonNewWithMnemonic "Replace _all" - replB <- buttonNewWithMnemonic "_Replace" - find <- buttonNewWithMnemonic "_Find" - - boxPackStart bb find PackNatural 0 - boxPackStart bb replB PackNatural 0 - boxPackStart bb replAll PackNatural 0 - - resList <- mapM (\ fd -> (fieldEditor fd) replace) replaceDescription - let (widgetsP, setInjsP, getExtsP, notifiersP) = unzip4 resList - mapM_ (\ w -> boxPackStart hb w PackNatural 0) widgetsP - let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of - Just s -> s - Nothing -> "Unnamed") replaceDescription - find `onClicked` do - findOrSearch editFind getExtsP fieldNames replB replAll ideR - - replB `onClicked` do - findOrSearch editReplace getExtsP fieldNames replB replAll ideR - - replAll `onClicked` do - findOrSearch editReplaceAll getExtsP fieldNames replB replAll ideR - - boxPackStart vb hb PackNatural 0 - boxPackStart vb bb PackNatural 0 - - let replace = IDEReplace vb - notebookInsertOrdered nb vb (paneName replace) - widgetShowAll vb - return (replace,[]) - addPaneAdmin buf (BufConnections [] [] []) panePath - lift $widgetGrabFocus (replaceBox buf) - where - findOrSearch :: (Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool) - -> [ReplaceState -> Extractor ReplaceState] -> [String] -> Button -> - Button -> IDERef -> IO() - findOrSearch f getExtsP fieldNames replB replAll ideR= do - mbReplaceState <- extractAndValidate replace getExtsP fieldNames - case mbReplaceState of - Nothing -> return () - Just rs -> do - let hint = if searchBackwards rs then Backward else Forward - found <- runReaderT (f (matchEntire rs) (matchCase rs) False - (searchFor rs) (replaceWith rs) hint) ideR - widgetSetSensitivity replB found - widgetSetSensitivity replAll found - return () - -replaceDescription :: [FieldDescription ReplaceState] -replaceDescription = [ - mkField - (paraName <<<- ParaName "Search for" $ emptyParams) - searchFor - (\ b a -> a{searchFor = b}) - stringEditor - , mkField - (paraName <<<- ParaName "Replace with" $ emptyParams) - replaceWith - (\ b a -> a{replaceWith = b}) - stringEditor - , mkField - (paraName <<<- ParaName "Match case" $ emptyParams) - matchCase - (\ b a -> a{matchCase = b}) - boolEditor - , mkField - (paraName <<<- ParaName "Entire word" $ emptyParams) - matchEntire - (\ b a -> a{matchEntire = b}) - boolEditor - , mkField - (paraName <<<- ParaName "Back" $ emptyParams) - searchBackwards - (\ b a -> a{searchBackwards = b}) - boolEditor] - -editReplace :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool -editReplace entireWord caseSensitive wrapAround search replace hint = - editReplace' entireWord caseSensitive wrapAround search replace hint True - -editReplace' :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> Bool -> IDEM Bool -editReplace' entireWord caseSensitive wrapAround search replace hint mayRepeat = - inBufContext' False $ \_ gtkbuf currentBuffer _ -> do - startMark <- lift $textBufferGetInsert gtkbuf - iter <- lift $textBufferGetIterAtMark gtkbuf startMark - iter2 <- lift $textIterCopy iter - lift $textIterForwardChars iter2 (length search) - str1 <- lift $textIterGetText iter iter2 - if compare str1 search caseSensitive - then do - lift $textBufferDelete gtkbuf iter iter2 - lift $textBufferInsert gtkbuf iter replace - editFind entireWord caseSensitive wrapAround search "" hint - else do - r <- editFind entireWord caseSensitive wrapAround search "" hint - if r - then editReplace' entireWord caseSensitive wrapAround search - replace hint False - else return False - where - compare s1 s2 True = s1 == s2 - compare s1 s2 False = map toUpper s1 == map toUpper s2 - -editReplaceAll :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool -editReplaceAll entireWord caseSensitive wrapAround search replace hint = do - res <- editReplace' entireWord caseSensitive wrapAround search replace hint True - if res - then editReplaceAll entireWord caseSensitive wrapAround search replace hint - else return False - - - diff --git a/src/IDE/SaveSession.hs b/src/IDE/SaveSession.hs --- a/src/IDE/SaveSession.hs +++ b/src/IDE/SaveSession.hs @@ -1,11 +1,11 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} +{-# OPTIONS_GHC -XTypeSynonymInstances #-} ----------------------------------------------------------------------------- -- -- Module : IDE.SaveSession -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL -- --- Maintainer : Juergen Nicklisch-Franken +-- Maintainer : Juergen Nicklisch-Franken -- Stability : experimental -- Portability : portable -- @@ -16,7 +16,14 @@ module IDE.SaveSession ( - SaveSessionAction(..) + saveSession +, saveSessionAs +, saveSessionAsPrompt +, recoverSession +, sessionClosePane +, loadSession +, loadSessionPrompt +, standardSessionFilename ) where import Graphics.UI.Gtk hiding (showLayout) @@ -25,62 +32,119 @@ import System.FilePath import qualified Data.Map as Map import Data.Maybe +import Data.Typeable --import GHC.Exception (catch) +--import Debug.Trace import IDE.Core.State -import IDE.Framework.ViewFrame -import IDE.Utils.File +import IDE.FileUtils import IDE.PrinterParser import qualified Text.PrettyPrint.HughesPJ as PP -import IDE.Framework.Parameters -import IDE.Package -import IDE.RecoverPanes +import Graphics.UI.Editor.Parameters +--import IDE.Package +import IDE.Pane.Modules +import IDE.Pane.SourceBuffer +import IDE.Pane.Info +import IDE.Pane.Callers +import IDE.Pane.Log +import IDE.Pane.Preferences +import IDE.Pane.PackageFlags +import IDE.Pane.Search +import IDE.Find +import System.Time (getClockTime) +import IDE.Package (activatePackage,deactivatePackage) +import Data.List (foldl') +-- --------------------------------------------------------------------- +-- All pane types must be in here ! +-- -instance IDEObject IDEAction +data PaneState = BufferSt BufferState + | LogSt LogState + | InfoSt InfoState + | ModulesSt ModulesState + | CallersSt CallersState + | PrefsSt PrefsState + | FlagsSt FlagsState + | SearchSt SearchState + deriving(Eq,Ord,Read,Show) -class IDEObject o => SaveSessionAction o where - saveSession :: o - recoverSession :: o - sessionClosePane :: o +asPaneState :: RecoverablePane alpha beta gamma => beta -> PaneState +asPaneState s | isJust ((cast s) :: Maybe BufferState) = BufferSt (fromJust $ cast s) +asPaneState s | isJust ((cast s) :: Maybe LogState) = LogSt (fromJust $ cast s) +asPaneState s | isJust ((cast s) :: Maybe InfoState) = InfoSt (fromJust $ cast s) +asPaneState s | isJust ((cast s) :: Maybe ModulesState) = ModulesSt (fromJust $ cast s) +asPaneState s | isJust ((cast s) :: Maybe CallersState) = CallersSt (fromJust $ cast s) +asPaneState s | isJust ((cast s) :: Maybe PrefsState) = PrefsSt (fromJust $ cast s) +asPaneState s | isJust ((cast s) :: Maybe FlagsState) = FlagsSt (fromJust $ cast s) +asPaneState s | isJust ((cast s) :: Maybe SearchState) = SearchSt (fromJust $ cast s) +asPaneState s = error "SaveSession>>asPaneState incomplete cast" -instance SaveSessionAction IDEAction where - saveSession = saveSession' - recoverSession = recoverSession' - sessionClosePane = sessionClosePane' +recover :: PanePath -> PaneState -> IDEAction +recover pp (BufferSt p) = recoverState pp p +recover pp (LogSt p) = recoverState pp p +recover pp (InfoSt p) = recoverState pp p +recover pp (ModulesSt p) = recoverState pp p +recover pp (CallersSt p) = recoverState pp p +recover pp (PrefsSt p) = recoverState pp p +recover pp (FlagsSt p) = recoverState pp p +recover pp (SearchSt p) = recoverState pp p +-- --------------------------------------------------------------------- + +standardSessionFilename = "Current.session" + -- | *Implementation -sessionClosePane' :: IDEAction -sessionClosePane' = do +sessionClosePane :: IDEAction +sessionClosePane = do activePane' <- readIDE activePane case activePane' of Nothing -> return () Just (pn,_) -> do - p <- paneFromName pn + (PaneC p) <- paneFromName pn close p -sessionFilename = "Current.session" - data SessionState = SessionState { - layoutS :: PaneLayout + saveTime :: String + , layoutS :: PaneLayout , population :: [(Maybe PaneState,PanePath)] , windowSize :: (Int,Int) , activePackage :: Maybe FilePath , activePaneN :: Maybe String + , toolbarVisibleS :: Bool + , findbarState :: (Bool,FindState) } deriving() defaultLayout = SessionState { - layoutS = TerminalP (Just TopP) (-1) + saveTime = "" + , layoutS = TerminalP (Just TopP) (-1) , population = [] , windowSize = (1024,768) , activePackage = Nothing - , activePaneN = Nothing} + , activePaneN = Nothing + , toolbarVisibleS = True + , findbarState = (False,FindState{ + entryStr = "" + , entryHist = [] + , replaceStr = "" + , replaceHist = [] + , caseSensitive = False + , entireWord = False + , wrapAround = True + , backward = False + , lineNr = 1})} layoutDescr :: [FieldDescriptionS SessionState] layoutDescr = [ mkFieldS + (paraName <<<- ParaName "Time of storage" $ emptyParams) + (PP.text . show) + stringParser + saveTime + (\ b a -> a{saveTime = b}) + , mkFieldS (paraName <<<- ParaName "Layout" $ emptyParams) (PP.text . show) readParser @@ -109,32 +173,145 @@ (PP.text . show) readParser activePaneN - (\fp a -> a{activePaneN = fp})] + (\fp a -> a{activePaneN = fp}) + , mkFieldS + (paraName <<<- ParaName "Toolbar visible" $ emptyParams) + (PP.text . show) + readParser + toolbarVisibleS + (\fp a -> a{toolbarVisibleS = fp}) + , mkFieldS + (paraName <<<- ParaName "FindbarState" $ emptyParams) + (PP.text . show) + readParser + findbarState + (\fp a -> a{findbarState = 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 +saveSession :: IDEAction +saveSession = do + sessionPath <- liftIO $getConfigFilePathForSave standardSessionFilename + saveSessionAs sessionPath +saveSessionAs :: FilePath -> IDEAction +saveSessionAs sessionPath = do + forget <- getForgetSession + if forget + then ideMessage Normal "Forget this session" + else do + ideMessage Normal "Now saving session" + wdw <- readIDE window + layout <- getLayout + population <- getPopulation + size <- liftIO $windowGetSize wdw + active <- getActive + activePane' <- readIDE activePane + let activeP = case activePane' of + Nothing -> Nothing + Just (s,_) -> Just s + toolbarVisible <- readIDE toolbarVisible + findState <- getFindState + timeNow <- liftIO getClockTime + liftIO $ writeLayout sessionPath (SessionState { + saveTime = show timeNow + , layoutS = layout + , population = population + , windowSize = size + , activePackage = active + , activePaneN = activeP + , toolbarVisibleS = toolbarVisible + , findbarState = (False,findState)}) + +saveSessionAsPrompt :: IDEAction +saveSessionAsPrompt = do + window' <- readIDE window + response <- liftIO $ do + configFolder <- getConfigDir + dialog <- fileChooserDialogNew + (Just $ "Save Session as") + (Just window') + FileChooserActionSave + [("gtk-cancel" + ,ResponseCancel) + ,("gtk-save" + , ResponseAccept)] + fileChooserSetCurrentFolder dialog configFolder + widgetShow dialog + res <- dialogRun dialog + case res of + ResponseAccept -> do + fileName <- fileChooserGetFilename dialog + widgetHide dialog + return fileName + _ -> do + widgetHide dialog + return Nothing + case response of + Just fn -> saveSessionAs fn + Nothing -> return () + +loadSessionPrompt :: IDEAction +loadSessionPrompt = do + window' <- readIDE window + response <- liftIO $ do + configFolder <- getConfigDir + dialog <- fileChooserDialogNew + (Just $ "Select session file") + (Just window') + FileChooserActionOpen + [("gtk-cancel" + ,ResponseCancel) + ,("gtk-open" + , ResponseAccept)] + fileChooserSetCurrentFolder dialog configFolder + widgetShow dialog + res <- dialogRun dialog + case res of + ResponseAccept -> do + fileName <- fileChooserGetFilename dialog + widgetHide dialog + return fileName + _ -> do + widgetHide dialog + return Nothing + case response of + Just fn -> loadSession fn + Nothing -> return () + +loadSession :: FilePath -> IDEAction +loadSession sessionPath = do + saveSession :: IDEAction + deactivatePackage + b <- fileCloseAll + if b + then do + paneCloseAll + viewCollapseAll + recoverSession sessionPath + return () + else return () + +paneCloseAll :: IDEAction +paneCloseAll = do + panes' <- readIDE panes + mapM_ (\ (PaneC p) -> close p) (Map.elems panes') + +viewCollapseAll :: IDEAction +viewCollapseAll = do + layout' <- readIDE layout + case layout' of + TerminalP _ _ -> return () + VerticalP _ _ _ -> viewCollapse' [LeftP] + HorizontalP _ _ _ -> viewCollapse' [TopP] + 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 + foldl' (\ doc (FDS _ printer _) -> doc PP.$+$ printer prefs) PP.empty prefsDesc getLayout :: IDEM(PaneLayout) getLayout = do @@ -145,19 +322,19 @@ l2 <- getLayout' l (pp ++ [TopP]) r2 <- getLayout' r (pp ++ [BottomP]) pane <- getPaned pp - pos <- lift $ panedGetPosition pane + pos <- liftIO $ 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 + pos <- liftIO $ 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 + showTabs <- liftIO $ notebookGetShowTabs nb + pos <- liftIO $ notebookGetTabPos nb + current <- liftIO $ notebookGetCurrentPage nb return (TerminalP (if showTabs then Just (posTypeToPaneDirection pos) else Nothing) current) @@ -166,12 +343,11 @@ getPopulation = do paneMap <- readIDE paneMap mapM (\ (pn,v) -> do - p <- paneFromName pn + (PaneC p) <- paneFromName pn mbSt <- saveState p - let st = case mbSt of - Nothing -> Nothing - Just s -> Just (toPaneState s) - return (st, fst v)) + case mbSt of + Nothing -> return (Nothing, fst v) + Just st -> return (Just (asPaneState st), fst v)) $Map.toList paneMap getActive :: IDEM(Maybe String) @@ -189,11 +365,11 @@ -- | Read and apply the saved layout -- -recoverSession' :: IDEAction -recoverSession' = do +recoverSession :: FilePath -> IDEM (Bool,Bool) +recoverSession sessionPath = do wdw <- readIDE window - layoutSt <- lift$ readLayout - lift $windowSetDefaultSize wdw (fst (windowSize layoutSt))(snd (windowSize layoutSt)) + layoutSt <- liftIO$ readLayout sessionPath + liftIO $windowSetDefaultSize wdw (fst (windowSize layoutSt))(snd (windowSize layoutSt)) applyLayout (layoutS layoutSt) case activePackage layoutSt of Just fp -> activatePackage fp >> return () @@ -202,15 +378,23 @@ setCurrentPages (layoutS layoutSt) when (isJust (activePaneN layoutSt)) $ do mbPane <- mbPaneFromName (fromJust (activePaneN layoutSt)) - when (isJust mbPane) $ - makeActive (fromJust mbPane) + case mbPane of + Nothing -> return () + Just (PaneC p) -> makeActive p + setFindState ((snd . findbarState) layoutSt) + if toolbarVisibleS layoutSt + then showToolbar + else hideToolbar + if (fst . findbarState) layoutSt + then showFindbar + else hideFindbar + return (toolbarVisibleS layoutSt, (fst . findbarState) layoutSt) -readLayout :: IO SessionState -readLayout = do - layoutPath <- getConfigFilePathForLoad sessionFilename - res <- parseFromFile (prefsParser defaultLayout layoutDescr) layoutPath +readLayout :: FilePath -> IO SessionState +readLayout sessionPath = do + res <- parseFromFile (prefsParser defaultLayout layoutDescr) sessionPath case res of - Left pe -> throwIDE $"Error reading prefs file " ++ show layoutPath ++ " " ++ show pe + Left pe -> throwIDE $"Error reading session file " ++ show sessionPath ++ " " ++ show pe Right r -> return r prefsParser :: a -> [FieldDescriptionS a] -> CharParser () a @@ -229,21 +413,21 @@ where applyLayout' (TerminalP Nothing _) pp = do nb <- getNotebook pp - lift $notebookSetShowTabs nb False + liftIO $notebookSetShowTabs nb False applyLayout' (TerminalP (Just p) _) pp = do nb <- getNotebook pp - lift $notebookSetShowTabs nb True - lift $notebookSetTabPos nb (paneDirectionToPosType p) + liftIO $notebookSetShowTabs nb True + liftIO $notebookSetTabPos nb (paneDirectionToPosType p) applyLayout' (VerticalP l r pos) pp = do viewSplit' pp Vertical pane <- getPaned pp - lift $panedSetPosition pane pos + liftIO $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 + liftIO $panedSetPosition pane pos applyLayout' t (pp ++ [TopP]) applyLayout' b (pp ++ [BottomP]) @@ -251,7 +435,7 @@ populate = mapM_ (\ (mbPs,pp) -> case mbPs of Nothing -> return () - Just s -> recoverState pp (paneStateToIDEState s)) + Just s -> recover pp s) setCurrentPages :: PaneLayout -> IDEAction setCurrentPages layout = setCurrentPages' layout [] @@ -262,7 +446,7 @@ setCurrentPages' r (RightP : p) setCurrentPages' (TerminalP _ ind) p = when (ind > 0) $ do nb <- getNotebook (reverse p) - lift $ notebookSetCurrentPage nb ind + liftIO $ notebookSetCurrentPage nb ind diff --git a/src/IDE/SourceCandy.hs b/src/IDE/SourceCandy.hs --- a/src/IDE/SourceCandy.hs +++ b/src/IDE/SourceCandy.hs @@ -4,7 +4,7 @@ -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL -- --- Maintainer : Juergen Nicklisch-Franken +-- Maintainer : Juergen Nicklisch-Franken -- Stability : experimental -- Portability : portable -- @@ -14,7 +14,11 @@ --------------------------------------------------------------------------------- module IDE.SourceCandy ( - SourceCandy(..) + parseCandy -- :: FilePath -> IO alpha +, transformToCandy -- :: alpha -> TextBuffer -> IO () +, transformFromCandy -- :: alpha -> TextBuffer -> IO () +, keystrokeCandy -- :: alpha -> Maybe Char -> TextBuffer -> IO () +, getCandylessText -- :: alpha -> TextBuffer -> IO String ) where import Data.Char(chr) @@ -30,35 +34,16 @@ 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 $['!','#','$','%','&','*','+','.','/','<','=','>','?','@','\\', - '^','|','-','~','\'','"'] + '^','|','-','~','\'','"','\n'] notAfterOp = notBeforeOp -keystrokeCandy' :: CandyTable -> Maybe Char -> TextBuffer -> IO () -keystrokeCandy' (CT(transformTable,_)) mbc gtkbuf = do +keystrokeCandy :: CandyTable -> Maybe Char -> TextBuffer -> IO () +keystrokeCandy (CT(transformTable,_)) mbc gtkbuf = do cursorMark <- textBufferGetInsert gtkbuf endIter <- textBufferGetIterAtMark gtkbuf cursorMark offset <- textIterGetOffset endIter @@ -68,15 +53,10 @@ 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 + textIterGetChar endIter replace mbc2 cursorMark slice offset transformTable where - replace :: Maybe Char -> TextMark -> String -> Int -> [(Bool,String,String)] -> IO () + replace :: Maybe Char -> TextMark -> String -> Int -> [(Bool,String,String)] -> IO () replace mbAfterChar cursorMark match offset list = replace' list where replace' [] = return () @@ -88,7 +68,7 @@ afterOk = case mbAfterChar of Nothing -> True Just afterChar -> - not $if isOp + not $if isOp then Set.member afterChar notAfterOp else Set.member afterChar notAfterId in if isSuffixOf from match && beforeOk && afterOk @@ -102,8 +82,8 @@ sourceBufferEndNotUndoableAction (castToSourceBuffer gtkbuf) else replace mbAfterChar cursorMark match offset rest -transformToCandy' :: CandyTable -> TextBuffer -> IO () -transformToCandy' (CT(transformTable,_)) gtkbuf = do +transformToCandy :: CandyTable -> TextBuffer -> IO () +transformToCandy (CT(transformTable,_)) gtkbuf = do textBufferBeginUserAction gtkbuf modified <- textBufferGetModified gtkbuf mapM_ (\tbl -> replaceTo gtkbuf tbl 0) transformTable @@ -154,26 +134,26 @@ return () replaceTo' (stOff + 1) -transformFromCandy' :: CandyTable -> TextBuffer -> IO () -transformFromCandy' (CT(_,transformTableBack)) gtkbuf = do +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 +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 + text1 <- textBufferGetText gtkbuf i1 i2 True + textBufferSetText workBuffer text1 mapM_ (\tbl -> replaceFrom workBuffer tbl 0) transformTableBack i1 <- textBufferGetStartIter workBuffer i2 <- textBufferGetEndIter workBuffer - text <- textBufferGetText workBuffer i1 i2 True - return text + text2 <- textBufferGetText workBuffer i1 i2 True + return text2 replaceFrom :: TextBuffer -> (String,String,Int) -> Int -> IO () replaceFrom buf (to,from,spaces) offset = replaceFrom' offset @@ -211,7 +191,7 @@ let isOp = not (Set.member (head str) notBeforeId) from = str trailingBlanks = replicate (if noTrimming then 0 else length str - 1) ' ' - to = [chr] ++ trailingBlanks + to = chr : trailingBlanks in (isOp,from,to) backFromTable :: CandyTableI -> CandyTableBack @@ -236,8 +216,8 @@ hexadecimal = P.hexadecimal lexer symbol = P.symbol lexer -parseCandy' :: FilePath -> IO CandyTable -parseCandy' fn = do +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 diff --git a/src/IDE/SourceEditor.hs b/src/IDE/SourceEditor.hs deleted file mode 100644 --- a/src/IDE/SourceEditor.hs +++ /dev/null @@ -1,894 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- --- Module : IDE.SourceEditor --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | The source editor part of Leksah --- ------------------------------------------------------------------------------------ - -module IDE.SourceEditor ( - allBuffers -, maybeActiveBuf -, standardSourcePanePath -, selectSourceBuf -, goToSourceDefinition -, goToDefinition - -, newTextBuffer - -, fileNew -, fileOpen -, fileRevert -, fileClose -, fileCloseAll -, fileCloseAllButPackage -, fileSave -, editUndo -, editRedo -, editCut -, editCopy -, editPaste -, editDelete -, editSelectAll - -, editComment -, editUncomment -, editShiftRight -, editShiftLeft - -, editToCandy -, editFromCandy -, editKeystrokeCandy -, editCandy - -, markErrorInSourceBuf -, inBufContext' -, inBufContext -) where - -import Graphics.UI.Gtk hiding (afterToggleOverwrite) -import Graphics.UI.Gtk.SourceView -import Graphics.UI.Gtk.Multiline.TextView -import Control.Monad.Reader ---import Data.IORef -import System.IO -import System.FilePath -import System.Directory -import Text.Printf -import qualified Data.Map as Map -import Data.List -import Data.Maybe - -import IDE.Core.State -import IDE.Utils.File -import IDE.Framework.ViewFrame -import IDE.SourceCandy - -instance IDEObject IDEBuffer -instance Pane IDEBuffer - where - primPaneName = bufferName - getAddedIndex = addedIndex - getTopWidget = castToWidget . scrolledWindow - paneId b = case fileName b of - Just s -> s - Nothing -> "?" ++ bufferName b - makeActive buf = do - pane <- paneFromName (paneName buf) - if isIt BufferCasting pane - then do - let actbuf = fromJust $ downCast BufferCasting pane - ideR <- ask - sbLC <- getStatusbarLC - sbIO <- getStatusbarIO - infos <- readIDE accessibleInfo - let sv = sourceView actbuf - (tl,tm,tr) <- lift $do - gtkBuf <- textViewGetBuffer sv - bringPaneToFront actbuf - writeCursorPositionInStatusbar sv sbLC - writeOverwriteInStatusbar sv sbIO - id1 <- gtkBuf `afterModifiedChanged` runReaderT (markLabelAsChanged) ideR - id2 <- sv `afterMoveCursor` - (\_ _ _ -> writeCursorPositionInStatusbar sv sbLC) - id3 <- gtkBuf `afterEndUserAction` writeCursorPositionInStatusbar sv sbLC - sv `widgetAddEvents` [ButtonReleaseMask] - id4 <- sv `onButtonRelease` (\ _ -> do - writeCursorPositionInStatusbar sv sbLC - return False) - id5 <- sv `onButtonRelease` (\ e -> do - showInfo sv ideR - return False) - id6 <- sv `afterToggleOverwrite` writeOverwriteInStatusbar sv sbIO - return ([id2,id4,id6],[id1,id3],[]) - activatePane actbuf (BufConnections tl tm tr) - checkModTime actbuf - else return () - close pane = do makeActive pane - fileClose - return () - -instance RecoverablePane IDEBuffer BufferState where - saveState p = do buf <- lift $ textViewGetBuffer (sourceView p) - ins <- lift $ textBufferGetInsert buf - iter <- lift $ textBufferGetIterAtMark buf ins - offset <- lift $ textIterGetOffset iter - case fileName p of - Nothing -> return Nothing - Just fn -> return (Just (StateC (BufferState fn offset))) - recoverState pp (BufferState n i) = do - exists <- lift $doesFileExist n - when exists $ do - buf <- newTextBuffer pp (takeFileName n) (Just n) - lift $ do - gtkBuf <- textViewGetBuffer (sourceView buf) - iter <- textBufferGetIterAtOffset gtkBuf i - textBufferPlaceCursor gtkBuf iter - mark <- textBufferGetInsert gtkBuf - textViewScrollToMark (sourceView buf) mark 0.0 (Just (0.3,0.3)) - return () - -selectSourceBuf :: FilePath -> IDEM Bool -selectSourceBuf fp = do - fpc <- lift $canonicalizePath fp - buffers <- allBuffers - let buf = filter (\b -> case fileName b of - Just fn -> equalFilePath fn fpc - Nothing -> False) buffers - case buf of - hdb:tl -> do - makeActive hdb - return True - otherwise -> do - fe <- lift $doesFileExist fpc - if fe - then do - path <- standardSourcePanePath - newTextBuffer path (takeFileName fpc) (Just fpc) - return True - else return False - -goToDefinition :: IdentifierDescr -> IDEAction -goToDefinition idDescr = do - mbAccesibleInfo <- readIDE accessibleInfo - mbCurrentInfo <- readIDE currentInfo - if isJust mbAccesibleInfo && isJust mbCurrentInfo - then do - let packageId = pack $ moduleIdID idDescr - let mbPack = case packageId `Map.lookup` fst - (fromJust mbAccesibleInfo) of - Just it -> Just it - Nothing -> packageId `Map.lookup` fst (fst - (fromJust mbCurrentInfo)) - case mbPack of - Just pack -> case filter (\md -> moduleIdMD md == moduleIdID idDescr) - (exposedModulesPD pack) of - [mod] -> if isJust (mbSourcePathMD mod) - then goToSourceDefinition - (fromJust $ mbSourcePathMD mod) - (mbLocation idDescr) - else return () - _ -> ideMessage Normal "not just one module" - Nothing -> do ideMessage Normal "no package" - else ideMessage Normal "no infos" - -goToSourceDefinition :: FilePath -> Maybe Location -> IDEAction -goToSourceDefinition fp mbLocation = do - success <- selectSourceBuf fp - when (success && isJust mbLocation) $ - inBufContext () $ \_ gtkbuf buf _ -> do - let location = fromJust mbLocation - lines <- textBufferGetLineCount gtkbuf - iter <- textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1) - ((locationSLine location) -1))) - chars <- textIterGetCharsInLine iter - textIterSetLineOffset iter (max 0 (min (chars-1) (locationSCol location))) - iter2 <- textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1) - ((locationELine location) -1))) - chars2 <- textIterGetCharsInLine iter2 - textIterSetLineOffset iter2 (max 0 (min (chars2-1) (locationECol location))) - textBufferPlaceCursor gtkbuf iter - smark <- textBufferGetSelectionBound gtkbuf - textBufferMoveMark gtkbuf smark iter2 - - imark <- textBufferGetInsert gtkbuf - -- ### we have a problem here that this does not work for a frsh opened buffer - textViewScrollToMark (sourceView buf) imark 0.0 (Just (0.3,0.3)) - - -markErrorInSourceBuf :: Int -> Int -> String -> IDEAction -markErrorInSourceBuf line column string = - inBufContext () $ \_ gtkbuf buf _ -> do - i1 <- textBufferGetStartIter gtkbuf - i2 <- textBufferGetEndIter gtkbuf - textBufferRemoveTagByName gtkbuf "activeErr" i1 i2 - - lines <- textBufferGetLineCount gtkbuf - iter <- textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1) (line-1))) - chars <- textIterGetCharsInLine iter - textIterSetLineOffset iter (max 0 (min (chars-1) column)) - iter2 <- textIterCopy iter - textIterForwardWordEnd iter2 - textBufferApplyTagByName gtkbuf "activeErr" iter iter2 - textBufferPlaceCursor gtkbuf iter - mark <- textBufferGetInsert gtkbuf - textViewScrollToMark (sourceView buf) mark 0.0 (Just (0.3,0.3)) - - -allBuffers :: IDEM [IDEBuffer] -allBuffers = do - panesST <- readIDE panes - return (catMaybes $ map (downCast BufferCasting) $ Map.elems panesST) - -maybeActiveBuf :: IDEM (Maybe (IDEBuffer,Connections)) -maybeActiveBuf = do - mbPane <- readIDE activePane - case mbPane of - Nothing -> return Nothing - Just (paneName,signals) -> do - pane <- paneFromName paneName - if isIt BufferCasting pane - then return (Just (fromJust $ downCast BufferCasting pane,signals)) - else return Nothing - -standardSourcePanePath :: IDEM PanePath -standardSourcePanePath = do - layout <- readIDE layout - prefs <- readIDE prefs - return (getStandardPanePath (sourcePanePath prefs) layout) - -newTextBuffer :: PanePath -> String -> Maybe FilePath -> IDEM IDEBuffer -newTextBuffer panePath bn mbfn = do - -- create the appropriate language - ideR <- ask - nb <- getNotebook panePath - panes <- readIDE panes - paneMap <- readIDE paneMap - prefs <- readIDE prefs - bs <- getCandyState - ct <- readIDE candy - let (ind,rbn) = figureOutPaneName panes bn 0 - (buf,cids) <- lift $ do - lm <- sourceLanguagesManagerNew - langM <- sourceLanguagesManagerGetLanguageFromMimeType lm "text/x-haskell" - lang <- case langM of - (Just lang) -> return lang - Nothing -> do - langDirs <- sourceLanguagesManagerGetLangFilesDirs lm - throwIDE ("please copy haskell.lang to one of the following" - ++ "directories:\n" - ++ unlines langDirs) - - -- create a new SourceBuffer object - buffer <- sourceBufferNewWithLanguage lang - tagTable <- textBufferGetTagTable buffer - foundTag <- textTagNew (Just "found") - set foundTag [textTagBackground := "yellow"] - textTagTableAdd tagTable foundTag - activeErrtag <- textTagNew (Just "activeErr") - set activeErrtag[textTagUnderline := UnderlineError] - textTagTableAdd tagTable activeErrtag - - -- load up and display a file - (fileContents,modTime) <- case mbfn of - Just fn -> do - fc <- readFile fn - mt <- getModificationTime fn - return (fc,Just mt) - Nothing -> return ("\n\n\n\n\n",Nothing) - sourceBufferBeginNotUndoableAction buffer - textBufferSetText buffer fileContents - if bs - then transformToCandy ct (castToTextBuffer buffer) - else return () - sourceBufferEndNotUndoableAction buffer - textBufferSetModified buffer False - siter <- textBufferGetStartIter buffer - textBufferPlaceCursor buffer siter - sourceBufferSetHighlight buffer True - iter <- textBufferGetEndIter buffer - textBufferCreateMark buffer (Just "end") iter True - - -- create a new SourceView Widget - sv <- sourceViewNewWithBuffer buffer - fd <- case textviewFont prefs of - Just str -> do - fontDescriptionFromString str - Nothing -> do - f <- fontDescriptionNew - fontDescriptionSetFamily f "Monospace" - return f - widgetModifyFont sv (Just fd) - sourceViewSetShowLineNumbers sv (showLineNumbers prefs) - case rightMargin prefs of - Just n -> do - sourceViewSetMargin sv n - sourceViewSetShowMargin sv True - Nothing -> sourceViewSetShowMargin sv True - sourceViewSetInsertSpacesInsteadOfTabs sv True - sourceViewSetTabsWidth sv (tabWidth prefs) - sourceViewSetSmartHomeEnd sv True - --sourceViewSetShowLineMarkers sv True - - -- put it in a scrolled window - sw <- scrolledWindowNew Nothing Nothing - containerAdd sw sv - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - scrolledWindowSetShadowType sw ShadowIn - - let buf = IDEBuffer mbfn bn ind sv sw modTime - notebookInsertOrdered nb sw rbn - -- events - cid <- sv `afterFocusIn` - (\_ -> do runReaderT (makeActive buf) ideR; return True) - return (buf,[cid]) - addPaneAdmin buf (BufConnections cids [] []) panePath - lift $widgetShowAll (scrolledWindow buf) - lift $widgetGrabFocus (sourceView buf) - return buf - -checkModTime :: IDEBuffer -> IDEAction -checkModTime buf = do - panes <- readIDE panes - let name = paneName buf - case fileName buf of - Just fn -> do - exists <- lift $doesFileExist fn - if exists - then do - nmt <- lift $getModificationTime fn - case modTime buf of - Nothing -> throwIDE $"checkModTime: time not set " ++ show (fileName buf) - Just mt -> do - --message $"checkModTime " ++ name ++ " " ++ show mt ++ " " ++ show nmt - if nmt /= mt - then do - md <- lift $messageDialogNew - Nothing [] - MessageQuestion - ButtonsYesNo - ("File has changed on disk " ++ name ++ " Revert?") - resp <- lift $dialogRun md - case resp of - ResponseYes -> do - revert buf - lift $widgetHide md - ResponseNo -> do - let newPanes = Map.adjust (\b -> - if isIt BufferCasting b - then PaneC ((fromJust $ - downCast BufferCasting b) - {modTime = (Just nmt)}) - else b) name panes - modifyIDE_ (\ide -> return (ide{panes = newPanes})) - lift $widgetHide md - _ -> do return () - else return () - else return () - Nothing -> return () - -setModTime :: IDEBuffer -> IDEAction -setModTime buf = do - panes <- readIDE panes - let name = paneName buf - case fileName buf of - Nothing -> return () - Just fn -> do - nmt <- lift $getModificationTime fn - let newPanes = Map.adjust ( - \b -> if isIt BufferCasting b - then - PaneC ((fromJust $ downCast BufferCasting b) - {modTime = (Just nmt)}) - else b) name panes - modifyIDE_ (\ide -> return (ide{panes = newPanes})) - -fileRevert :: IDEAction -fileRevert = inBufContext' () $ \ _ _ currentBuffer _ -> do - revert currentBuffer - -revert :: IDEBuffer -> IDEAction -revert buf = do - useCandy <- getCandyState - ct <- readIDE candy - panes <- readIDE panes - let name = paneName buf - case fileName buf of - Nothing -> return () - Just fn -> do - mt <- lift $do - buffer' <- textViewGetBuffer (sourceView buf) - let buffer = castToSourceBuffer buffer' - fc <- readFile fn - mt <- getModificationTime fn - sourceBufferBeginNotUndoableAction buffer - textBufferSetText buffer fc - if useCandy - then transformToCandy ct (castToTextBuffer buffer) - else return () - sourceBufferEndNotUndoableAction buffer - textBufferSetModified buffer False - return mt - let newPanes = Map.adjust (\b -> if isIt BufferCasting b - then - PaneC ((fromJust $ downCast BufferCasting b) - {modTime = (Just mt)}) - else b) name panes - modifyIDE_ (\ide -> return (ide{panes = newPanes})) - -writeCursorPositionInStatusbar :: SourceView -> Statusbar -> IO() -writeCursorPositionInStatusbar sv sb = do - buf <- textViewGetBuffer sv - mark <- textBufferGetInsert buf - iter <- textBufferGetIterAtMark buf mark - line <- textIterGetLine iter - col <- textIterGetLineOffset iter - statusbarPop sb 1 - statusbarPush sb 1 $printf "Ln %4d, Col %3d" (line + 1) (col + 1) - return () - -writeOverwriteInStatusbar :: SourceView -> Statusbar -> IO() -writeOverwriteInStatusbar sv sb = do - modi <- textViewGetOverwrite sv - statusbarPop sb 1 - statusbarPush sb 1 $ if modi then "OVR" else "INS" - return () - - -showInfo :: SourceView -> IDERef -> IO () -showInfo sv ideR = do - buf <- textViewGetBuffer sv - (l,r) <- textBufferGetSelectionBounds buf - symbol <- textBufferGetText buf l r True - runReaderT (triggerEvent ideR (SelectInfo symbol)) ideR - return () - -markLabelAsChanged :: IDEAction -markLabelAsChanged = do - mbPath <- getActivePanePath - case mbPath of - Nothing -> return () - Just path -> do - nb <- getNotebook path - mbBS <- maybeActiveBuf - case mbBS of - Nothing -> return () - Just (buf,_) -> lift $do - gtkbuf <- textViewGetBuffer (sourceView buf) - modified <- textBufferGetModified gtkbuf - (Just text) <- notebookGetTabLabelText nb (scrolledWindow buf) - label <- labelNew Nothing - labelSetUseMarkup label True - labelSetMarkup label - (if modified - then "" ++ text ++ "" - else text) - notebookSetTabLabel nb (scrolledWindow buf) label - -inBufContext' :: alpha -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM alpha ) -> IDEM alpha -inBufContext' def f = do - mbBuf <- maybeActiveBuf - case mbBuf of - Nothing -> return def - Just (ideBuf,_) -> do - (pane,_) <- guiPropertiesFromName (paneName ideBuf) - nb <- getNotebook pane - mbI <- lift $notebookPageNum nb (scrolledWindow ideBuf) - case mbI of - Nothing -> lift $ do - sysMessage Normal "notebook page not found: unexpected" - return def - Just i -> do - gtkbuf <- lift $ textViewGetBuffer (sourceView ideBuf) - f nb gtkbuf ideBuf i - -inBufContext :: alpha -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IO alpha ) -> IDEM alpha -inBufContext def f = inBufContext' def (\ a b c d -> lift $ f a b c d) - -fileSave :: Bool -> IDEAction -fileSave query = inBufContext' () $ \ nb _ currentBuffer i -> do - ideR <- ask - window <- readIDE window - bufs <- readIDE panes - prefs <- readIDE prefs - paneMap <- readIDE paneMap - bs <- getCandyState - candy <- readIDE candy - (panePath,BufConnections s1 s2 s3) - <- guiPropertiesFromName (paneName currentBuffer) - mbnbufsPm <- do - let mbfn = fileName currentBuffer - mbpage <- lift $notebookGetNthPage nb i - case mbpage of - Nothing -> throwIDE "fileSave: Page not found" - Just page -> - if isJust mbfn && query == False - then do checkModTime currentBuffer - lift $fileSave' (forceLineEnds prefs) currentBuffer bs candy $fromJust mbfn - setModTime currentBuffer - return Nothing - else lift $do - dialog <- fileChooserDialogNew - (Just $ "Save File") - (Just window) - FileChooserActionSave - [("gtk-cancel" --buttons to display - ,ResponseCancel) --you can use stock buttons - ,("gtk-save" - , ResponseAccept)] - widgetShow dialog - response <- dialogRun dialog - mbFileName <- case response of - ResponseAccept -> fileChooserGetFilename dialog - ResponseCancel -> return Nothing - ResponseDeleteEvent-> return Nothing - _ -> return Nothing - widgetDestroy dialog - case mbFileName of - Nothing -> return Nothing - Just fn -> do - dfe <- doesFileExist fn - resp <- if dfe - then do md <- messageDialogNew (Just window) [] - MessageQuestion - ButtonsYesNo - "File already exist. Overwrite?" - resp <- dialogRun md - widgetHide md - return resp - else return ResponseYes - case resp of - ResponseYes -> do - fileSave' (forceLineEnds prefs) currentBuffer bs candy fn - modT <- getModificationTime fn - let bn = takeFileName fn - let bufs1 = Map.delete (paneName currentBuffer) bufs - let (ind,rbn) = figureOutPaneName bufs1 bn 0 - cfn <- canonicalizePath fn - let newBuffer = currentBuffer {fileName = Just cfn, - bufferName = bn, addedIndex = ind, modTime = Just modT} - let newBufs = Map.insert rbn (PaneC newBuffer) bufs1 - mapM_ signalDisconnect s1 - mapM_ signalDisconnect s2 - mapM_ signalDisconnect s3 - cid1 <- (sourceView currentBuffer) `afterFocusIn` - (\_ -> do runReaderT (makeActive newBuffer) ideR - return True) - let paneMap1 = Map.delete rbn paneMap - let newPaneMap = Map.insert rbn - (panePath,BufConnections [cid1] [] []) paneMap - label <- labelNew (Just rbn) - notebookSetTabLabel nb page label - return (Just (newBufs,newPaneMap)) - ResponseNo -> return Nothing - _ -> return Nothing - case mbnbufsPm of - Just (nbufs,pm) -> modifyIDE_ - (\ide -> return (ide{panes = nbufs, paneMap = pm})) - Nothing -> return () - where - fileSave' :: Bool -> IDEBuffer -> Bool -> CandyTable -> FilePath -> IO() - fileSave' forceLineEnds ideBuf bs ct fn = do - buf <- textViewGetBuffer $ sourceView ideBuf - text <- getCandylessText ct buf - let text' = unlines $map removeTrailingBlanks $lines text - if forceLineEnds - then do - file <- openBinaryFile fn WriteMode - hPutStr file text' - hClose file - else - writeFile fn text' - textBufferSetModified buf False - removeTrailingBlanks :: String -> String - removeTrailingBlanks = reverse . dropWhile (\c -> c == ' ') . reverse - -fileNew :: IDEAction -fileNew = do - prefs <- readIDE prefs - pp <- getActivePanePathOrStandard (sourcePanePath prefs) - newTextBuffer pp "Unnamed" Nothing - return () - -fileClose :: IDEM Bool -fileClose = inBufContext' True $ fileClose' - -fileClose' :: Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM Bool -fileClose' nb gtkbuf currentBuffer i = do - ideRef <- ask - window <- readIDE window - bufs <- readIDE panes - paneMap <- readIDE paneMap - cancel <- lift $ do - modified <- textBufferGetModified gtkbuf - if modified - then do - md <- messageDialogNew (Just window) [] - MessageQuestion - ButtonsNone - ("Save changes to document: " - ++ paneName currentBuffer - ++ "?") - dialogAddButton md "_Save" ResponseYes - dialogAddButton md "_Don't Save" ResponseNo - dialogAddButton md "_Cancel" ResponseCancel - resp <- dialogRun md - widgetDestroy md - case resp of - ResponseYes -> do - runReaderT (fileSave False) ideRef - return False - ResponseCancel -> return True - ResponseNo -> return False - _ -> return False - else return False - if cancel - then return False - else do - deactivatePane - lift $notebookRemovePage nb i - removePaneAdmin currentBuffer - return True - - -fileCloseAll :: IDEM Bool -fileCloseAll = do - bufs <- allBuffers - if null bufs - then return True - else do - makeActive (head bufs) - r <- fileClose - if r - then fileCloseAll - else return False - - -fileCloseAllButPackage :: IDEAction -fileCloseAllButPackage = do - mbActivePack <- readIDE activePack - bufs <- allBuffers - when (not (null bufs) && isJust mbActivePack) $ do - mapM_ (close' (fromJust mbActivePack)) bufs - where - close' activePack buf = do - (pane,_) <- guiPropertiesFromName (paneName buf) - nb <- getNotebook pane - mbI <- lift $notebookPageNum nb (scrolledWindow buf) - case mbI of - Nothing -> throwIDE "notebook page not found: unexpected" - Just i -> do - gtkbuf <- lift $ textViewGetBuffer (sourceView buf) - let dir = dropFileName $ cabalFile activePack - when (isJust (fileName buf)) $ do - modified <- lift $ textBufferGetModified gtkbuf - when (not modified && not (isSubPath dir (fromJust (fileName buf)))) - $ do fileClose' nb gtkbuf buf i; return () - -fileOpen :: IDEAction -fileOpen = do - window <- readIDE window - prefs <- readIDE prefs - mbFileName <- lift $ do - dialog <- fileChooserDialogNew - (Just $ "Open File") - (Just window) - FileChooserActionOpen - [("gtk-cancel" - ,ResponseCancel) - ,("gtk-open" - ,ResponseAccept)] - widgetShow dialog - response <- dialogRun dialog - case response of - ResponseAccept -> do - f <- fileChooserGetFilename dialog - widgetDestroy dialog - return f - ResponseCancel -> do - widgetDestroy dialog - return Nothing - ResponseDeleteEvent-> do - widgetDestroy dialog - return Nothing - _ -> return Nothing - case mbFileName of - Nothing -> return () - Just fp -> do - fpc <- lift $canonicalizePath fp - buffers <- allBuffers - let buf = filter (\b -> case fileName b of - Just fn -> equalFilePath fn fpc - Nothing -> False) buffers - case buf of - hdb:tl -> do - md <- lift $messageDialogNew - Nothing [] - MessageQuestion - ButtonsYesNo - ("Buffer already open. " ++ - "Make active instead of opening a second time?") - resp <- lift $dialogRun md - lift $ widgetDestroy md - case resp of - ResponseNo -> reallyOpen prefs fpc - _ -> makeActive hdb - [] -> reallyOpen prefs fpc - where - reallyOpen prefs fpc = do - pp <- getActivePanePathOrStandard (sourcePanePath prefs) - newTextBuffer pp (takeFileName fpc) (Just fpc) - return () - -editUndo :: IDEAction -editUndo = inBufContext () $ \_ gtkbuf _ _ -> - let sb = castToSourceBuffer gtkbuf in - do canUndo <- sourceBufferCanUndo sb - if canUndo - then sourceBufferUndo sb - else return () - -editRedo :: IDEAction -editRedo = inBufContext () $ \_ gtkbuf _ _ -> - let sb = castToSourceBuffer gtkbuf in - do canRedo <- sourceBufferCanUndo sb - if canRedo - then sourceBufferRedo sb - else return () - -editDelete :: IDEAction -editDelete = inBufContext () $ \_ gtkbuf _ _ -> do - textBufferDeleteSelection gtkbuf True True - return () - -editSelectAll :: IDEAction -editSelectAll = inBufContext () $ \_ gtkbuf _ _ -> do - start <- textBufferGetStartIter gtkbuf - end <- textBufferGetEndIter gtkbuf - textBufferSelectRange gtkbuf start end - -editCut :: IDEAction -#ifdef _Newgtk -editCut = inBufContext () $ \_ gtkbuf _ _ -> do - clip <- clipboardGet ClipClipboard - textBufferCutClipboard gtkbuf clip True -#else -editCut = return () -#endif - -editCopy :: IDEAction -#ifdef _Newgtk -editCopy = inBufContext () $ \_ gtkbuf _ _ -> do - clip <- clipboardGet ClipClipboard - textBufferCopyClipboard gtkbuf clip -#else -editCopy = return () -#endif - -editPaste :: IDEAction -#ifdef _Newgtk -editPaste = inBufContext () $ \_ gtkbuf _ _ -> do - mark <- textBufferGetInsert gtkbuf - iter <- textBufferGetIterAtMark gtkbuf mark - clip <- clipboardGet ClipClipboard - textBufferPasteClipboard gtkbuf clip iter True -#else -editPaste = return () -#endif - - -getStartAndEndLineOfSelection :: TextBuffer -> IO (Int,Int) -getStartAndEndLineOfSelection gtkbuf = do - startMark <- textBufferGetInsert gtkbuf - endMark <- textBufferGetSelectionBound gtkbuf - startIter <- textBufferGetIterAtMark gtkbuf startMark - endIter <- textBufferGetIterAtMark gtkbuf endMark - startLine <- textIterGetLine startIter - endLine <- textIterGetLine endIter - let (startLine',endLine',endIter') = if endLine >= startLine - then (startLine,endLine,endIter) - else (endLine,startLine,startIter) - b <- textIterStartsLine endIter' - let endLineReal = if b then endLine' - 1 else endLine' - return (startLine',endLineReal) - -doForSelectedLines :: [a] -> (TextBuffer -> TextIter -> Int -> IO a) -> IDEM [a] -doForSelectedLines d f = inBufContext' d $ \_ gtkbuf currentBuffer _ -> lift $do - (start,end) <- getStartAndEndLineOfSelection gtkbuf - iter <- textBufferGetStartIter gtkbuf - mapM (f gtkbuf iter) [start .. end] - -editComment :: IDEAction -editComment = do - doForSelectedLines [] $ \gtkbuf iter lineNr -> do - textIterSetLine iter lineNr - textBufferInsert gtkbuf iter "--" - return () - -editUncomment :: IDEAction -editUncomment = do - doForSelectedLines [] $ \gtkbuf iter lineNr -> do - textIterSetLine iter lineNr - iter2 <- textIterCopy iter - textIterForwardChars iter 2 - str <- textIterGetText iter iter2 - if str == "--" - then do textBufferDelete gtkbuf iter iter2 - else return () - return () - -editShiftLeft :: IDEAction -editShiftLeft = do - prefs <- readIDE prefs - let str = map (\_->' ') [1 .. (tabWidth prefs)] - b <- canShiftLeft str prefs - if b - then do - doForSelectedLines [] $ \gtkbuf iter lineNr -> do - textIterSetLine iter lineNr - iter2 <- textIterCopy iter - textIterForwardChars iter (tabWidth prefs) - textBufferDelete gtkbuf iter iter2 - return () - else return () - where - canShiftLeft str prefs = do - boolList <- doForSelectedLines [] $ \gtkbuf iter lineNr -> do - textIterSetLine iter lineNr - iter2 <- textIterCopy iter - textIterForwardChars iter (tabWidth prefs) - str1 <- textIterGetText iter iter2 - return (str1 == str) - return (foldl (&&) True boolList) - - -editShiftRight :: IDEAction -editShiftRight = do - prefs <- readIDE prefs - let str = map (\_->' ') [1 .. (tabWidth prefs)] - doForSelectedLines [] $ \gtkbuf iter lineNr -> do - textIterSetLine iter lineNr - textBufferInsert gtkbuf iter str - return () - -editToCandy :: IDEAction -editToCandy = do - ct <- readIDE candy - inBufContext () $ \_ gtkbuf _ _ -> do - transformToCandy ct gtkbuf - -editFromCandy :: IDEAction -editFromCandy = do - ct <- readIDE candy - inBufContext () $ \_ gtkbuf _ _ -> do - transformFromCandy ct gtkbuf - -editKeystrokeCandy :: Maybe Char -> IDEAction -editKeystrokeCandy c = do - ct <- readIDE candy - inBufContext () $ \_ gtkbuf _ _ -> do - keystrokeCandy ct c gtkbuf - -editCandy = do - ct <- readIDE candy - buffers <- allBuffers - gtkbufs <- lift $mapM (\ b -> textViewGetBuffer (sourceView b)) buffers - bs <- getCandyState - if bs - then lift $mapM_ (transformToCandy ct) gtkbufs - else lift $mapM_ (transformFromCandy ct) gtkbufs - - - - - - - - diff --git a/src/IDE/SpecialEditors.hs b/src/IDE/SpecialEditors.hs --- a/src/IDE/SpecialEditors.hs +++ b/src/IDE/SpecialEditors.hs @@ -14,35 +14,45 @@ , stringsEditor , extensionsEditor , panePathEditor +, libraryEditor +, executablesEditor +, modulesEditor +, styleEditor +, Library'(..) +, Executable'(..) ) where +import Graphics.UI.Editor.Simple (intEditor,genericEditor,staticListEditor,comboSelectionEditor,stringEditor,fileEditor) import Graphics.UI.Gtk import Graphics.UI.Gtk.ModelView as New +import Graphics.UI.Gtk.SourceView (sourceStyleSchemeManagerGetSchemeIds) +import Graphics.UI.Gtk.SourceView (sourceStyleSchemeManagerNew) +import Distribution.ModuleName (ModuleName(..)) +import Data.List (sort) +import Distribution.Text (simpleParse,display) 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 +import IDE.Core.State hiding (packageId) +import Graphics.UI.Editor.Basics +import Graphics.UI.Editor.Composite +import Graphics.UI.Editor.Parameters +import Default +import MyMissing packageEditor :: Editor PackageIdentifier -packageEditor para = do - (wid,inj,ext,notif) <- pairEditor - (stringEditor, paraName <<<- ParaName "Name" $ emptyParams) +packageEditor para noti = do + (wid,inj,ext) <- pairEditor + (stringEditor (\s -> not (null s)), paraName <<<- ParaName "Name" $ emptyParams) (versionEditor, paraName <<<- ParaName "Version" $ emptyParams) (paraDirection <<<- ParaDirection Horizontal $ paraShadow <<<- ParaShadow ShadowIn - $ para) - let pinj (PackageIdentifier n v) = inj (n,v) + $ para) noti + let pinj (PackageIdentifier (PackageName n) v) = inj (n,v) let pext = do mbp <- ext case mbp of @@ -50,14 +60,14 @@ Just (n,v) -> do if null n then return Nothing - else return (Just $PackageIdentifier n v) - return (wid,pinj,pext,notif) + else return (Just $PackageIdentifier (PackageName n) v) + return (wid,pinj,pext) testedWidthEditor :: Editor [(CompilerFlavor, VersionRange)] testedWidthEditor para = do multisetEditor - (ColumnDescr False [("Compiler Flavor",\(cv,_) -> [New.cellText := show cv]) - ,("Version Range",\(_,vr) -> [New.cellText := showVersionRange vr])]) + (ColumnDescr True [("Compiler Flavor",\(cv,_) -> [New.cellText := show cv]) + ,("Version Range",\(_,vr) -> [New.cellText := display vr])]) (pairEditor (compilerFlavorEditor, paraShadow <<<- (ParaShadow ShadowNone) $ emptyParams) (versionRangeEditor, paraShadow <<<- (ParaShadow ShadowNone) $ emptyParams), @@ -65,12 +75,15 @@ 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) +compilerFlavorEditor para noti = do + noti2 <- emptyNotifier + noti3 <- emptyNotifier + (wid,inj,ext) <- eitherOrEditor + (comboSelectionEditor flavors , paraName <<<- (ParaName "Select compiler") $ emptyParams) + (stringEditor (\s -> not (null s)), paraName <<<- (ParaName "Specify compiler") $ emptyParams) "Other" (paraName <<<- ParaName "Select" $ para) + noti let cfinj comp = case comp of (OtherCompiler str) -> inj (Right "") other -> inj (Left other) @@ -80,33 +93,44 @@ Nothing -> return Nothing Just (Right s) -> return (Just $OtherCompiler s) Just (Left other) -> return (Just other) - return (wid,cfinj,cfext,notif) + return (wid,cfinj,cfext) where flavors = [GHC, NHC, Hugs, HBC, Helium, JHC] versionRangeEditor :: Editor VersionRange -versionRangeEditor para = do - (wid,inj,ext,notif) <- +versionRangeEditor para noti = do + (wid,inj,ext) <- maybeEditor (eitherOrEditor (pairEditor - (staticSelectionEditor v1, emptyParams) + (comboSelectionEditor v1, emptyParams) (versionEditor, paraName <<<- ParaName "Enter Version" $ emptyParams), (paraDirection <<<- ParaDirection Vertical) - $ paraName <<<- ParaName "Simple Version Range" - $ emptyParams) + $ paraOuterAlignment <<<- ParaOuterAlignment (0.0, 0.0, 0.0, 0.0) + $ paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0) + $ paraInnerAlignment <<<- ParaInnerAlignment (0.0, 0.0, 0.0, 0.0) + $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0) + $ emptyParams) (pairEditor - (staticSelectionEditor v2, emptyParams) + (comboSelectionEditor 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) + $ paraOuterAlignment <<<- ParaOuterAlignment (0.0, 0.0, 0.0, 0.0) + $ paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0) + $ paraInnerAlignment <<<- ParaInnerAlignment (0.0, 0.0, 0.0, 0.0) + $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0) + $ emptyParams ) "Complex",paraName <<<- ParaName "Simple" + $ paraOuterAlignment <<<- ParaOuterAlignment (0.0, 0.0, 0.0, 0.0) + $ paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0) + $ paraInnerAlignment <<<- ParaInnerAlignment (0.0, 0.0, 0.0, 0.0) + $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0) $ emptyParams) False "Any Version" (paraDirection <<<- ParaDirection Vertical $ para) + noti let vrinj AnyVersion = inj Nothing vrinj (ThisVersion v) = inj (Just (Left (ThisVersionS,v))) vrinj (LaterVersion v) = inj (Just (Left (LaterVersionS,v))) @@ -136,7 +160,7 @@ -> return (Just (UnionVersionRanges v1 v2)) Just (Just (Right (IntersectVersionRangesS,(v1,v2)))) -> return (Just (IntersectVersionRanges v1 v2)) - return (wid,vrinj,vrext,notif) + return (wid,vrinj,vrext) where v1 = [ThisVersionS,LaterVersionS,ThisOrLaterVersionS,EarlierVersionS,ThisOrEarlierVersionS] v2 = [UnionVersionRangesS,IntersectVersionRangesS] @@ -157,65 +181,82 @@ show IntersectVersionRangesS = "Intersect Version Ranges" versionEditor :: Editor Version -versionEditor para = do - (wid,inj,ext,notiRef) <- stringEditor para - let pinj v = inj (showVersion v) +versionEditor para noti = do + (wid,inj,ext) <- stringEditor (\s -> not (null s)) para noti + let pinj v = inj (display 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) + Just s -> return (simpleParse s) + return (wid, pinj, pext) -dependencyEditor :: Editor Dependency -dependencyEditor para = do - (wid,inj,ext,notif) <- pairEditor - (stringEditor,paraName <<<- ParaName "Package Name" $ emptyParams) +dependencyEditor :: [PackageIdentifier] -> Editor Dependency +dependencyEditor packages para noti = do + (wid,inj,ext) <- pairEditor + (comboSelectionEditor (sort (map (display . pkgName) packages)) + , paraName <<<- ParaName "Package Name" $ emptyParams) (versionRangeEditor,paraName <<<- ParaName "Version" $ emptyParams) (paraDirection <<<- ParaDirection Vertical $ para) - let pinj (Dependency s v) = inj (s,v) + noti + let pinj (Dependency (PackageName 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) + Just (s,v) -> return (Just $Dependency (PackageName s) v) + return (wid,pinj,pext) -dependenciesEditor :: Editor [Dependency] -dependenciesEditor p = +dependenciesEditor :: [PackageIdentifier] -> Editor [Dependency] +dependenciesEditor packages p noti = multisetEditor - (ColumnDescr True [("Package",\(Dependency str _) -> [New.cellText := str]) - ,("Version",\(Dependency _ vers) -> [New.cellText := showVersionRange vers])]) - (dependencyEditor,emptyParams) - (paraShadow <<<- ParaShadow ShadowIn $ p) + (ColumnDescr True [("Package",\(Dependency (PackageName str) _) -> [New.cellText := str]) + ,("Version",\(Dependency _ vers) -> [New.cellText := display vers])]) + (dependencyEditor packages, + paraOuterAlignment <<<- ParaInnerAlignment (0.0, 0.5, 1.0, 1.0) + $ paraInnerAlignment <<<- ParaOuterAlignment (0.0, 0.5, 1.0, 1.0) + $ emptyParams) + (paraShadow <<<- ParaShadow ShadowIn $ + paraOuterAlignment <<<- ParaInnerAlignment (0.0, 0.5, 1.0, 1.0) + $ paraInnerAlignment <<<- ParaOuterAlignment (0.0, 0.5, 1.0, 1.0) + $ paraDirection <<<- ParaDirection Vertical + $ paraPack <<<- ParaPack PackGrow + $ p) + noti 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) + (paraShadow <<<- ParaShadow ShadowIn $ + paraDirection <<<- ParaDirection Vertical $ p) -stringsEditor :: Editor [String] -stringsEditor p = +stringsEditor :: (String -> Bool) -> Editor [String] +stringsEditor validation p = multisetEditor (ColumnDescr False [("",(\row -> [New.cellText := row]))]) - (stringEditor, emptyParams) + (stringEditor validation, emptyParams) (paraShadow <<<- ParaShadow ShadowIn $ p) panePathEditor :: Editor StandardPath -panePathEditor = staticSelectionEditor [LeftTop,LeftBottom,RightTop,RightBottom] +panePathEditor = genericEditor extensionsEditor :: Editor [Extension] -extensionsEditor = staticMultiselectionEditor extensionsL +extensionsEditor p = staticListEditor extensionsL (paraMultiSel <<<- ParaMultiSel True $ p) +styleEditor :: Editor (Maybe String) +styleEditor p n = do + styleManager <- sourceStyleSchemeManagerNew + ids <- sourceStyleSchemeManagerGetSchemeIds styleManager + maybeEditor (comboSelectionEditor ids, p) True "Select a special style?" p n + + extensionsL :: [Extension] -extensionsL = [ +extensionsL = knownExtensions + +{--[ OverlappingInstances , UndecidableInstances , IncoherentInstances @@ -246,9 +287,113 @@ , GeneralizedNewtypeDeriving , ExtensibleRecords , RestrictedTypeSynonyms - , HereDocuments] + , HereDocuments]--} -- ------------------------------------------------------------ +-- * BuildInfos +-- ------------------------------------------------------------ + +data Library' = Library'{ + exposedModules' :: [ModuleName] +, libExposed' :: Bool +, libBuildInfoIdx :: Int} + deriving (Show, Eq) + +data Executable' = Executable'{ + exeName' :: String +, modulePath' :: FilePath +, buildInfoIdx :: Int} + deriving (Show, Eq) + +instance Default Library' + where getDefault = Library' [] getDefault getDefault + +instance Default Executable' + where getDefault = Executable' getDefault getDefault getDefault + + +libraryEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor Library' +libraryEditor fp modules numBuildInfos para noti = do + (wid,inj,ext) <- + pairEditor + (modulesEditor modules, + paraName <<<- ParaName "Exposed Modules" + $ paraPack <<<- ParaPack PackGrow + $ paraMinSize <<<- ParaMinSize (-1,500) + $ para) + (buildInfoEditorP numBuildInfos, paraName <<<- ParaName "Build Info" + $ paraPack <<<- ParaPack PackNatural + $ para) + (paraDirection <<<- ParaDirection Vertical + $ paraPack <<<- ParaPack PackGrow + $ emptyParams) + noti + let pinj (Library' em True bi) = inj (map display em,bi) + pinj _ = throwIDE "SpecialEditors>>libraryEditor: No Library" + let pext = do + mbp <- ext + case mbp of + Nothing -> return Nothing + Just (em,bi) -> return (Just $Library' (map (\s -> forceJust (simpleParse s) + "SpecialEditor >> libraryEditor: no parse for moduile name") em) True bi) + return (wid,pinj,pext) + +moduleEditor :: [ModuleName] -> Editor String +moduleEditor modules = comboSelectionEditor (map display modules) + +modulesEditor :: [ModuleName] -> Editor [String] +modulesEditor modules = staticListEditor (map display modules) + +executablesEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor [Executable'] +executablesEditor fp modules countBuildInfo p = + multisetEditor + (ColumnDescr True [("Executable Name",\(Executable' exeName _ _) -> [New.cellText := exeName]) + ,("Module Path",\(Executable' _ mp _) -> [New.cellText := mp]) + + ,("Build info index",\(Executable' _ _ bii) -> [New.cellText := show (bii + 1)])]) + (executableEditor fp modules countBuildInfo,emptyParams) + (paraShadow <<<- ParaShadow ShadowIn $ p) + +executableEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor Executable' +executableEditor fp modules countBuildInfo para noti = do + (wid,inj,ext) <- pairEditor + (pairEditor + (stringEditor (\s -> not (null s)), + paraName <<<- ParaName "Executable Name" + $ emptyParams) + (stringEditor (\s -> not (null s)), + paraDirection <<<- ParaDirection Vertical + $ paraName <<<- ParaName "File with main function" + $ emptyParams), para) + (buildInfoEditorP countBuildInfo, paraName <<<- ParaName "Build Info" + $ paraOuterAlignment <<<- ParaOuterAlignment (0.0, 0.0, 0.0, 0.0) + $ paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0) + $ paraInnerAlignment <<<- ParaInnerAlignment (0.0, 0.0, 0.0, 0.0) + $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0) + $ emptyParams) + (paraDirection <<<- ParaDirection Vertical $ para) + noti + 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) + +buildInfoEditorP :: Int -> Editor Int +buildInfoEditorP numberOfBuildInfos para noti = do + (wid,inj,ext) <- intEditor (1.0,fromIntegral numberOfBuildInfos,1.0) + (paraName <<<- ParaName "Build Info" $para) noti + let pinj i = inj (i + 1) + let pext = do + mbV <- ext + case mbV of + Nothing -> return Nothing + Just i -> return (Just (i - 1)) + return (wid,pinj,pext) + +-- ------------------------------------------------------------ -- * (Boring) default values -- ------------------------------------------------------------ @@ -259,11 +404,7 @@ 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 + where getDefault = forceJust (simpleParse "0") "SpecialEditors>>default version" instance Default VersionRange where getDefault = AnyVersion @@ -275,7 +416,7 @@ where getDefault = emptyBuildInfo instance Default Library - where getDefault = Library [] getDefault + where getDefault = Library [] getDefault getDefault instance Default Dependency where getDefault = Dependency getDefault getDefault @@ -283,7 +424,8 @@ instance Default Executable where getDefault = Executable getDefault getDefault getDefault - +instance Default PackageName + where getDefault = PackageName getDefault diff --git a/src/IDE/ToolbarPane.hs b/src/IDE/ToolbarPane.hs deleted file mode 100644 --- a/src/IDE/ToolbarPane.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} ------------------------------------------------------------------------------ --- --- Module : IDE.ToolbarPane --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | The pane of ide where modules are presented in tree form with their --- packages and exports --- -------------------------------------------------------------------------------- - -module IDE.ToolbarPane ( - getToolbar -) where - -import Graphics.UI.Gtk hiding (get) -import Data.Maybe -import Control.Monad.Reader - -import IDE.Core.State -import IDE.Framework.ViewFrame - -instance IDEObject IDEToolbar -instance Pane IDEToolbar - where - primPaneName _ = "Toolbar" - getTopWidget = castToWidget . toolbar - paneId b = "*Toolbar" - makeActive p = throwIDE "don't activate toolbar" - close pane = do - (panePath,_) <- guiPropertiesFromName (paneName pane) - nb <- getNotebook panePath - mbI <- lift $notebookPageNum nb (getTopWidget pane) - case mbI of - Nothing -> lift $ do - sysMessage Normal "notebook page not found: unexpected" - return () - Just i -> do - deactivatePaneIfActive pane - lift $notebookRemovePage nb i - removePaneAdmin pane - - -instance RecoverablePane IDEToolbar ToolbarState where - saveState p = do - mbToolbar <- getPane ToolbarCasting - case mbToolbar of - Nothing -> return Nothing - Just p -> lift $ do - return (Just (StateC ToolbarState)) - recoverState pp ToolbarState = do - nb <- getNotebook pp - initToolbar pp nb - -getToolbar :: IDEM IDEToolbar -getToolbar = do - mbToolbar <- getPane ToolbarCasting - case mbToolbar of - Nothing -> do - prefs <- readIDE prefs - layout <- readIDE layout - let pp = getStandardPanePath (controlPanePath prefs) layout - nb <- getNotebook pp - initToolbar pp nb - mbToolbar <- getPane ToolbarCasting - case mbToolbar of - Nothing -> throwIDE "Can't init control pane" - Just m -> return m - Just m -> return m - -initToolbar :: PanePath -> Notebook -> IDEAction -initToolbar panePath nb = do - ideR <- ask - currentInfo <- readIDE currentInfo - res <- triggerEvent ideR (GetToolbar []) - let (tb1,tb2) = case res of - GetToolbar (_:t1:t2:_) -> (t1,t2) - _ -> throwIDE "Failed to build toolbar" - (buf,cids) <- lift $ do - vb <- vBoxNew False 0 - boxPackStart vb tb1 PackNatural 0 - boxPackStart vb tb2 PackNatural 0 - let toolbar' = IDEToolbar vb - notebookInsertOrdered nb vb (paneName toolbar') - widgetShowAll vb - return (toolbar',[]) - addPaneAdmin buf (BufConnections [] [] []) panePath - lift $widgetGrabFocus (toolbar buf) - diff --git a/src/IDE/Utils/DeepSeq.hs b/src/IDE/Utils/DeepSeq.hs deleted file mode 100644 --- a/src/IDE/Utils/DeepSeq.hs +++ /dev/null @@ -1,60 +0,0 @@ -module IDE.Utils.DeepSeq where - -class DeepSeq a where - deepSeq :: a -> b -> b - -infixr 0 `deepSeq`, $!! - -($!!) :: (DeepSeq a) => (a -> b) -> a -> b -f $!! x = x `deepSeq` f x - -instance DeepSeq () where deepSeq = seq - -instance DeepSeq Bool where deepSeq = seq -instance DeepSeq Char where deepSeq = seq - -instance (DeepSeq a) => DeepSeq (Maybe a) where - deepSeq Nothing y = y - deepSeq (Just x) y = deepSeq x y - -instance (DeepSeq a, DeepSeq b) => DeepSeq (Either a b) where - deepSeq (Left a) y = deepSeq a y - deepSeq (Right b) y = deepSeq b y - -instance DeepSeq Ordering where deepSeq = seq - -instance DeepSeq Int where deepSeq = seq -instance DeepSeq Integer where deepSeq = seq -instance DeepSeq Float where deepSeq = seq -instance DeepSeq Double where deepSeq = seq - -instance DeepSeq (a -> b) where deepSeq = seq - -instance DeepSeq (IO a) where deepSeq = seq - -instance (DeepSeq a) => DeepSeq [a] where - deepSeq [] y = y - deepSeq (x:xs) y = deepSeq x $ deepSeq xs y - -instance (DeepSeq a,DeepSeq b) => DeepSeq (a,b) where - deepSeq (a,b) y = deepSeq a $ deepSeq b y - -instance (DeepSeq a,DeepSeq b,DeepSeq c) => DeepSeq (a,b,c) where - deepSeq (a,b,c) y = deepSeq a $ deepSeq b $ deepSeq c y - -instance (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d) => DeepSeq (a,b,c,d) where - deepSeq (a,b,c,d) y = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d y - -instance (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d,DeepSeq e) => DeepSeq (a,b,c,d,e) where - deepSeq (a,b,c,d,e) y = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d $ deepSeq e y - -instance (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d,DeepSeq e,DeepSeq f) => DeepSeq (a,b,c,d,e,f) where - deepSeq (a,b,c,d,e,f) y = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d $ deepSeq e $ deepSeq f y - -instance (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d,DeepSeq e,DeepSeq f,DeepSeq g) => DeepSeq (a,b,c,d,e,f,g) where - deepSeq (a,b,c,d,e,f,g) y = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d $ deepSeq e $ deepSeq f $ deepSeq g y - - - - - diff --git a/src/IDE/Utils/Default.hs b/src/IDE/Utils/Default.hs deleted file mode 100644 --- a/src/IDE/Utils/Default.hs +++ /dev/null @@ -1,40 +0,0 @@ - ------------------------------------------------------------------------------ --- --- Module : IDE.Utils.Default --- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : experimental --- Portability : portable --- --- | Module for default values of a data type --- ------------------------------------------------------------------------------- - -module IDE.Utils.Default ( - Default(..) -) where - --- --- | A class for providing default values for certain types of editors --- -class Default alpha where - getDefault :: alpha - -instance Default Int where - getDefault = 1 - -instance Default alpha => Default (Either alpha beta) where - getDefault = Left(getDefault) - -instance (Default alpha, Default beta) => Default (alpha, beta) where - getDefault = (getDefault,getDefault) - -instance Default [alpha] where - getDefault = [] - -instance Default (Maybe alpha) where - getDefault = Nothing - diff --git a/src/IDE/Utils/File.hs b/src/IDE/Utils/File.hs deleted file mode 100644 --- a/src/IDE/Utils/File.hs +++ /dev/null @@ -1,252 +0,0 @@ -module IDE.Utils.File ( - allModules -, allHiFiles -, allHaskellSourceFiles -, cabalFileName -, allCabalFiles -, getConfigFilePathForLoad -, hasConfigDir -, getConfigFilePathForSave -, getCollectorPath -, getSysLibDir -, moduleNameFromFilePath -, findKnownPackages -, isSubPath -, findSourceFile - -) where - -import System.FilePath -import System.Directory -import System.IO -import Data.Char -import System.Process -import Text.ParserCombinators.Parsec hiding (Parser) -import qualified Text.ParserCombinators.Parsec.Token as P -import Text.ParserCombinators.Parsec.Language(haskell,haskellDef) -import Data.Maybe (catMaybes) -import Distribution.Simple.PreProcess.Unlit -import Control.Monad -import qualified Data.List as List -import qualified Data.Set as Set -import Data.Set (Set) -import Data.List(isSuffixOf, isPrefixOf) - -import Paths_leksah -import IDE.Core.State - --- | Returns True if the second path is a location which starts with the first path -isSubPath :: FilePath -> FilePath -> Bool -isSubPath fp1 fp2 = - let fpn1 = splitPath $ normalise fp1 - fpn2 = splitPath $ normalise fp2 - res = isPrefixOf fpn1 fpn2 - in res - -findSourceFile :: [FilePath] - -> [String] - -> ModuleIdentifier - -> IO (Maybe FilePath) -findSourceFile directories exts modId = - let modulePath = dots_to_slashes modId - allPathes = map (\ d -> d modulePath) directories - allPossibles = concatMap (\ p -> map (addExtension p) exts) - allPathes - in find' allPossibles - -find' :: [FilePath] -> IO (Maybe FilePath) -find' [] = return Nothing -find' (h:t) = do - exists <- doesFileExist h - if exists - then return (Just h) - else find' t - -dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) - --- The directory where config files reside --- -getConfigDir :: IO FilePath -getConfigDir = do - d <- getHomeDirectory - let filePath = d ".leksah" - exists <- doesDirectoryExist filePath - if exists - then return filePath - else do - createDirectory filePath - return filePath - -hasConfigDir :: IO Bool -hasConfigDir = do - d <- getHomeDirectory - let filePath = d ".leksah" - doesDirectoryExist filePath - - -getConfigFilePathForLoad :: String -> IO FilePath -getConfigFilePathForLoad fn = do - cd <- getConfigDir - ex <- doesFileExist (cd fn) - if ex - then return (cd fn) - else do - dd <- getDataDir - ex <- doesFileExist (dd "data" fn) - if ex - then return (dd "data" fn) - else throwIDE $"Config file not found: " ++ fn - -getConfigFilePathForSave :: String -> IO FilePath -getConfigFilePathForSave fn = do - cd <- getConfigDir - return (cd fn) - -allModules :: FilePath -> IO [String] -allModules filePath = do - exists <- doesDirectoryExist filePath - if exists - then do - filesAndDirs <- getDirectoryContents filePath - let filesAndDirs' = map (\s -> combine filePath s) - $filter (\s -> s /= "." && s /= ".." && s /= "_darcs" && s /= "dist" - && s /= "Setup.lhs") filesAndDirs - dirs <- filterM (\f -> doesDirectoryExist f) filesAndDirs' - files <- filterM (\f -> doesFileExist f) filesAndDirs' - let hsFiles = filter (\f -> let ext = takeExtension f in - ext == ".hs" || ext == ".lhs") files - mbModuleNames <- mapM moduleNameFromFilePath hsFiles - otherModules <- mapM allModules dirs - return (catMaybes mbModuleNames ++ concat otherModules) - else return [] - -allHiFiles :: FilePath -> IO [FilePath] -allHiFiles = allFilesWithExtensions [".hi"] True - -allCabalFiles :: FilePath -> IO [FilePath] -allCabalFiles = allFilesWithExtensions [".cabal"] False - -allHaskellSourceFiles :: FilePath -> IO [FilePath] -allHaskellSourceFiles = allFilesWithExtensions [".hs",".lhs"] True - -allFilesWithExtensions :: [String] -> Bool -> FilePath -> IO [FilePath] -allFilesWithExtensions extensions recurseFurther filePath = do - exists <- doesDirectoryExist filePath - if exists - then do - filesAndDirs <- getDirectoryContents filePath - let filesAndDirs' = map (\s -> combine filePath s) - $filter (\s -> s /= "." && s /= ".." && s /= "_darcs") filesAndDirs - dirs <- filterM (\f -> doesDirectoryExist f) filesAndDirs' - files <- filterM (\f -> doesFileExist f) filesAndDirs' - let choosenFiles = filter (\f -> let ext = takeExtension f in - List.elem ext extensions) files - otherFiles <- - if recurseFurther || (not recurseFurther && null choosenFiles) - then mapM (allFilesWithExtensions extensions recurseFurther) dirs - else return [] - return (choosenFiles ++ concat otherFiles) - else return [] - - - -moduleNameFromFilePath :: FilePath -> IO (Maybe String) -moduleNameFromFilePath fp = do - exists <- doesFileExist fp - if exists - then do - str <- readFile fp - let str' = if takeExtension fp == ".lhs" - then unlit fp str - else str - let parseRes = parse moduleNameParser fp str' - case parseRes of - Left err -> do - sysMessage Normal $show err - return Nothing - Right str -> do - return (Just str) - else return Nothing - -lexer = haskell -lexeme = P.lexeme lexer -whiteSpace = P.whiteSpace lexer -hexadecimal = P.hexadecimal lexer -symbol = P.symbol lexer - -moduleNameParser :: CharParser () String -moduleNameParser = do - whiteSpace - many skipPreproc - whiteSpace - symbol "module" - str <- lexeme mident --- skipMany anyChar --- eof - return str - "module identifier" - -skipPreproc :: CharParser () () -skipPreproc = do - try (do - whiteSpace - char '#' - many (noneOf "\n") - return ()) - "preproc" - -mident - = do{ c <- P.identStart haskellDef - ; cs <- many (alphaNum <|> oneOf "_'.") - ; return (c:cs) - } - "midentifier" - -findKnownPackages :: FilePath -> IO (Set String) -findKnownPackages filePath = do - paths <- getDirectoryContents filePath - let nameList = map dropExtension $filter (\s -> ".pack" `isSuffixOf` s) paths - return (Set.fromList nameList) - -cabalFileName :: FilePath -> IO (Maybe String) -cabalFileName filePath = do - exists <- doesDirectoryExist filePath - if exists - then do - filesAndDirs <- getDirectoryContents filePath - files <- filterM (\f -> doesFileExist f) filesAndDirs - let cabalFiles = filter (\f -> let ext = takeExtension f in ext == ".cabal") files - if null cabalFiles - then return Nothing - else if length cabalFiles == 1 - then return (Just $head cabalFiles) - else do - sysMessage Normal "Multiple cabal files" - return Nothing - else return Nothing - -getCollectorPath :: String -> IO FilePath -getCollectorPath version = do - configDir <- getConfigDir - let filePath = configDir "ghc-" ++ version - exists <- doesDirectoryExist filePath - if exists - then return filePath - else do - createDirectory filePath - return filePath - -getSysLibDir :: IO FilePath -getSysLibDir = do - (_, out, _, pid) <- runInteractiveProcess "ghc" ["--print-libdir"] Nothing Nothing - libDir <- hGetLine out - let libDir2 = if ord (last libDir) == 13 - then take (length libDir - 1) libDir - else libDir - waitForProcess pid - return (normalise libDir2) - - - - - diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,4 +1,22 @@ -import IDE.Leksah +----------------------------------------------------------------------------- +-- +-- Module : Main +-- Copyright : 2007-2009 Jürgen Nicklisch-Franken +-- License : GPL +-- +-- Maintainer : Jutaro +-- Stability : provisional +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Main ( +main +) where + +import IDE.Leksah (runMain) main = runMain diff --git a/src/MyMissing.hs b/src/MyMissing.hs new file mode 100644 --- /dev/null +++ b/src/MyMissing.hs @@ -0,0 +1,68 @@ +{-# OPTIONS_GHC -XScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Module : MyMissing +-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : experimental +-- Portability : portable +-- +-- | Module for missing base functions +-- +------------------------------------------------------------------------------ + +module MyMissing ( + allOf +, forceJust +, forceHead +, split +, replace +) where + +import Data.List (unfoldr) + +allOf :: forall alpha. (Bounded alpha, Enum alpha) => [alpha] +allOf = map toEnum [fromEnum (minBound :: alpha) .. fromEnum (maxBound :: alpha)] + +-- --------------------------------------------------------------------- +-- Convenience methods with error handling +-- +forceJust :: Maybe alpha -> String -> alpha +forceJust mb str = case mb of + Nothing -> error str + Just it -> it + +-- --------------------------------------------------------------------- +-- Convenience methods with error handling +-- +forceHead :: [alpha] -> String -> alpha +forceHead (h:_) str = h +forceHead [] str = error str + + +-- --------------------------------------------------------------------- +-- Splitting a string into parts based on a token delimiter +-- + +split :: Eq a => a -> [a] -> [[a]] +split = unfoldr . split' + +split' :: Eq a => a -> [a] -> Maybe ([a], [a]) +split' c l + | null l = Nothing + | otherwise = Just (h, drop 1 t) + where (h, t) = span (/=c) l + +-- --------------------------------------------------------------------- +-- Simple replacement +-- + +replace :: Eq a => [a] -> [a] -> [a] -> [a] +replace _ _ [] = [] +replace from to xs@(a:as) = + if isPrefixOf from xs + then to ++ replace from to (drop (length from) xs) + else a : replace from to as + where isPrefixOf as bs = and $ zipWith (== ) as bs