diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,339 @@ + GNU GENERAL PUBLIC LICENSE + Version 2, June 1991 + + Copyright (C) 1989, 1991 Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The licenses for most software are designed to take away your +freedom to share and change it. By contrast, the GNU General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. This +General Public License applies to most of the Free Software +Foundation's software and to any other program whose authors commit to +using it. (Some other Free Software Foundation software is covered by +the GNU Lesser General Public License instead.) You can apply it to +your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Our General Public Licenses are designed to make sure that you +have the freedom to distribute copies of free software (and charge for +this service if you wish), that you receive source code or can get it +if you want it, that you can change the software or use pieces of it +in new free programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must show them these terms so they know their +rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + Finally, any free program is threatened constantly by software +patents. We wish to avoid the danger that redistributors of a free +program will individually obtain patent licenses, in effect making the +program proprietary. To prevent this, we have made it clear that any +patent must be licensed for everyone's free use or not licensed at all. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License applies to any program or other work which contains +a notice placed by the copyright holder saying it may be distributed +under the terms of this General Public License. The "Program", below, +refers to any such program or work, and a "work based on the Program" +means either the Program or any derivative work under copyright law: +that is to say, a work containing the Program or a portion of it, +either verbatim or with modifications and/or translated into another +language. (Hereinafter, translation is included without limitation in +the term "modification".) Each licensee is addressed as "you". + +Activities other than copying, distribution and modification are not +covered by this License; they are outside its scope. The act of +running the Program is not restricted, and the output from the Program +is covered only if its contents constitute a work based on the +Program (independent of having been made by running the Program). +Whether that is true depends on what the Program does. + + 1. You may copy and distribute verbatim copies of the Program's +source code as you receive it, in any medium, provided that you +conspicuously and appropriately publish on each copy an appropriate +copyright notice and disclaimer of warranty; keep intact all the +notices that refer to this License and to the absence of any warranty; +and give any other recipients of the Program a copy of this License +along with the Program. + +You may charge a fee for the physical act of transferring a copy, and +you may at your option offer warranty protection in exchange for a fee. + + 2. You may modify your copy or copies of the Program or any portion +of it, thus forming a work based on the Program, and copy and +distribute such modifications or work under the terms of Section 1 +above, provided that you also meet all of these conditions: + + a) You must cause the modified files to carry prominent notices + stating that you changed the files and the date of any change. + + b) You must cause any work that you distribute or publish, that in + whole or in part contains or is derived from the Program or any + part thereof, to be licensed as a whole at no charge to all third + parties under the terms of this License. + + c) If the modified program normally reads commands interactively + when run, you must cause it, when started running for such + interactive use in the most ordinary way, to print or display an + announcement including an appropriate copyright notice and a + notice that there is no warranty (or else, saying that you provide + a warranty) and that users may redistribute the program under + these conditions, and telling the user how to view a copy of this + License. (Exception: if the Program itself is interactive but + does not normally print such an announcement, your work based on + the Program is not required to print an announcement.) + +These requirements apply to the modified work as a whole. If +identifiable sections of that work are not derived from the Program, +and can be reasonably considered independent and separate works in +themselves, then this License, and its terms, do not apply to those +sections when you distribute them as separate works. But when you +distribute the same sections as part of a whole which is a work based +on the Program, the distribution of the whole must be on the terms of +this License, whose permissions for other licensees extend to the +entire whole, and thus to each and every part regardless of who wrote it. + +Thus, it is not the intent of this section to claim rights or contest +your rights to work written entirely by you; rather, the intent is to +exercise the right to control the distribution of derivative or +collective works based on the Program. + +In addition, mere aggregation of another work not based on the Program +with the Program (or with a work based on the Program) on a volume of +a storage or distribution medium does not bring the other work under +the scope of this License. + + 3. You may copy and distribute the Program (or a work based on it, +under Section 2) in object code or executable form under the terms of +Sections 1 and 2 above provided that you also do one of the following: + + a) Accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of Sections + 1 and 2 above on a medium customarily used for software interchange; or, + + b) Accompany it with a written offer, valid for at least three + years, to give any third party, for a charge no more than your + cost of physically performing source distribution, a complete + machine-readable copy of the corresponding source code, to be + distributed under the terms of Sections 1 and 2 above on a medium + customarily used for software interchange; or, + + c) Accompany it with the information you received as to the offer + to distribute corresponding source code. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form with such + an offer, in accord with Subsection b above.) + +The source code for a work means the preferred form of the work for +making modifications to it. For an executable work, complete source +code means all the source code for all modules it contains, plus any +associated interface definition files, plus the scripts used to +control compilation and installation of the executable. However, as a +special exception, the source code distributed need not include +anything that is normally distributed (in either source or binary +form) with the major components (compiler, kernel, and so on) of the +operating system on which the executable runs, unless that component +itself accompanies the executable. + +If distribution of executable or object code is made by offering +access to copy from a designated place, then offering equivalent +access to copy the source code from the same place counts as +distribution of the source code, even though third parties are not +compelled to copy the source along with the object code. + + 4. You may not copy, modify, sublicense, or distribute the Program +except as expressly provided under this License. Any attempt +otherwise to copy, modify, sublicense or distribute the Program is +void, and will automatically terminate your rights under this License. +However, parties who have received copies, or rights, from you under +this License will not have their licenses terminated so long as such +parties remain in full compliance. + + 5. You are not required to accept this License, since you have not +signed it. However, nothing else grants you permission to modify or +distribute the Program or its derivative works. These actions are +prohibited by law if you do not accept this License. Therefore, by +modifying or distributing the Program (or any work based on the +Program), you indicate your acceptance of this License to do so, and +all its terms and conditions for copying, distributing or modifying +the Program or works based on it. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the +original licensor to copy, distribute or modify the Program subject to +these terms and conditions. You may not impose any further +restrictions on the recipients' exercise of the rights granted herein. +You are not responsible for enforcing compliance by third parties to +this License. + + 7. If, as a consequence of a court judgment or allegation of patent +infringement or for any other reason (not limited to patent issues), +conditions are imposed on you (whether by court order, agreement or +otherwise) that contradict the conditions of this License, they do not +excuse you from the conditions of this License. If you cannot +distribute so as to satisfy simultaneously your obligations under this +License and any other pertinent obligations, then as a consequence you +may not distribute the Program at all. For example, if a patent +license would not permit royalty-free redistribution of the Program by +all those who receive copies directly or indirectly through you, then +the only way you could satisfy both it and this License would be to +refrain entirely from distribution of the Program. + +If any portion of this section is held invalid or unenforceable under +any particular circumstance, the balance of the section is intended to +apply and the section as a whole is intended to apply in other +circumstances. + +It is not the purpose of this section to induce you to infringe any +patents or other property right claims or to contest validity of any +such claims; this section has the sole purpose of protecting the +integrity of the free software distribution system, which is +implemented by public license practices. Many people have made +generous contributions to the wide range of software distributed +through that system in reliance on consistent application of that +system; it is up to the author/donor to decide if he or she is willing +to distribute software through any other system and a licensee cannot +impose that choice. + +This section is intended to make thoroughly clear what is believed to +be a consequence of the rest of this License. + + 8. If the distribution and/or use of the Program is restricted in +certain countries either by patents or by copyrighted interfaces, the +original copyright holder who places the Program under this License +may add an explicit geographical distribution limitation excluding +those countries, so that distribution is permitted only in or among +countries not thus excluded. In such case, this License incorporates +the limitation as if written in the body of this License. + + 9. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of this License which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +this License, you may choose any version ever published by the Free Software +Foundation. + + 10. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to the public, the best way to achieve this is to make it +free software which everyone can redistribute and change under these terms. + + To do so, attach the following notices to the program. It is safest +to attach them to the start of each source file to most effectively +convey the exclusion of warranty; and each file should have at least +the "copyright" line and a pointer to where the full notice is found. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/data/guiCommonAskpass.glade b/data/guiCommonAskpass.glade new file mode 100644 --- /dev/null +++ b/data/guiCommonAskpass.glade @@ -0,0 +1,109 @@ + + + + + + + + + + + + + + False + Enter Password + + + True + False + + + True + False + + + True + False + Enter Password: + + + True + True + 0 + + + + + 300 + True + True + False + • + False + False + True + True + + + True + True + 1 + + + + + True + True + 0 + + + + + True + False + end + + + gtk-cancel + True + True + True + actCancel + False + True + + + False + False + 0 + + + + + gtk-ok + True + True + True + actOk + False + True + + + False + False + 1 + + + + + False + True + end + 1 + + + + + + diff --git a/data/guiCommonCommit.glade b/data/guiCommonCommit.glade new file mode 100644 --- /dev/null +++ b/data/guiCommonCommit.glade @@ -0,0 +1,125 @@ + + + + + + Cancel + gtk-cancel + + + Commit + gtk-ok + + + Enter commit message here. + + + False + Commit + + + True + False + + + True + True + automatic + automatic + + + True + True + bufferMsg + + + + + True + True + 0 + + + + + True + True + automatic + automatic + + + True + True + + + + + True + True + 1 + + + + + True + False + + + + + + True + False + 0 + 0 + + + True + False + + + True + True + True + actCancel + + + False + False + 0 + + + + + True + True + True + actCommit + + + False + False + 1 + + + + + + + False + True + 1 + + + + + False + True + 10 + 2 + + + + + + diff --git a/data/guiCommonConflictsResolved.glade b/data/guiCommonConflictsResolved.glade new file mode 100644 --- /dev/null +++ b/data/guiCommonConflictsResolved.glade @@ -0,0 +1,89 @@ + + + + + Browse + + + Conflicts not resolved + Conflicts not resolved + gtk-no + + + Conflicts resolved + Conflicts resolved + gtk-yes + + + False + Choose Path for Mergetool + + + True + False + + + True + False + 0.47999998927116394 + Have conflicts been resolved? + + + True + True + 0 + + + + + True + False + 1 + 0 + + + True + False + + + Cancel + True + True + True + actConflictsNotResolved + True + + + False + False + 0 + + + + + True + True + True + actConflictsResolved + True + top + + + False + False + 1 + + + + + + + False + True + 1 + + + + + + diff --git a/data/guiCommonFilesInConflict.glade b/data/guiCommonFilesInConflict.glade new file mode 100644 --- /dev/null +++ b/data/guiCommonFilesInConflict.glade @@ -0,0 +1,142 @@ + + + + + Browse + Browse + + + Cancel + Cancel + + + Conflicts Resolved + Conflicts Resolved + + + False + Files in Conflict + + + True + False + 4 + + + True + False + There is at least one file in conflict. Resolve conflicts first before you can commit. + center + + + + + True + True + + + True + True + + + + + + + + 1 + 2 + + + + + True + False + 3 + + + True + False + MergeTool + + + 5 + + + + + True + True + ● + True + + + 1 + 2 + 5 + + + + + True + True + True + actBrowsePath + True + 0.52999997138977051 + + + 2 + 3 + GTK_EXPAND + + + + + 2 + 3 + + + + + True + False + end + + + True + True + True + actCancel + True + + + False + False + 0 + + + + + True + True + True + actResolved + True + + + False + False + 1 + + + + + 3 + 4 + + + + + + diff --git a/data/guiCommonLog.glade b/data/guiCommonLog.glade new file mode 100644 --- /dev/null +++ b/data/guiCommonLog.glade @@ -0,0 +1,160 @@ + + + + + + + + Cancel + Cancel + gtk-cancel + + + + + + Checkout + Checkout + + + + + + False + Log viewer + + + True + False + + + True + False + 0 + 0 + 0 + 0 + + + True + False + + + False + True + Branch: + + + True + True + 0 + + + + + False + True + + + True + True + 1 + + + + + + + False + True + 0 + + + + + True + False + + + True + True + automatic + automatic + + + True + True + + + + + + + True + True + 1 + + + + + False + True + label + + + True + True + 2 + + + + + True + False + 1 + 0 + + + True + False + + + True + True + True + actCancel + True + + + False + False + 0 + + + + + True + True + True + actCheckout + True + + + False + False + 1 + + + + + + + False + True + 3 + + + + + + diff --git a/data/guiCommonMergeTool.glade b/data/guiCommonMergeTool.glade new file mode 100644 --- /dev/null +++ b/data/guiCommonMergeTool.glade @@ -0,0 +1,125 @@ + + + + + Browse + + + Cancel + Cancel + gtk-cancel + + + Ok + Ok + gtk-ok + + + False + Choose Path for Mergetool + + + True + False + + + True + False + 3 + + + True + False + Path + + + + + Browse + True + True + True + actBrowsePath + False + True + 0.52999997138977051 + + + 2 + 3 + + + + + True + True + ● + True + + + 1 + 2 + + + + + True + True + 0 + + + + + True + False + 1 + 0 + + + True + False + + + Cancel + True + True + True + actCancel + True + + + False + False + 0 + + + + + gtk-ok + True + True + True + actUse + False + True + True + + + False + False + 1 + + + + + + + False + True + 1 + + + + + + diff --git a/data/guiCommonSetupRepo.glade b/data/guiCommonSetupRepo.glade new file mode 100644 --- /dev/null +++ b/data/guiCommonSetupRepo.glade @@ -0,0 +1,377 @@ + + + + + Browse + Browse + + + + + + + + Cancel + Cancel + gtk-cancel + + + + + + + + Ok + Ok + gtk-ok + + + + + + + + + + + GIT + + + SVN + + + + + 600 + 400 + False + Setup Repository + center + + + True + False + + + True + False + 6 + 4 + + + True + False + Author Email + + + 1 + 2 + 4 + 5 + + + + + True + False + Author + + + 1 + 2 + 3 + 4 + + + + + True + True + • + True + False + False + + + 2 + 4 + 3 + 4 + + + + + True + True + • + True + False + False + + + 2 + 4 + 4 + 5 + + + + + Browse + True + True + True + actBrowseRepo + False + True + + + 3 + 4 + GTK_FILL + + + + + + True + False + Type of VCS + + + 1 + 2 + 1 + 2 + + + + + True + False + liststore1 + + + 2 + 4 + 1 + 2 + GTK_FILL + + + + + + True + False + False + False + • + False + False + + + 2 + 3 + + + + + True + False + Executable + + + 1 + 2 + 2 + 3 + + + + + True + True + • + False + False + + + 2 + 3 + 2 + 3 + + + + + Browse + True + True + True + actBrowseExec + False + True + + + 3 + 4 + 2 + 3 + GTK_EXPAND + + + + + Custom author + True + True + False + False + True + + + 3 + 5 + + + + + Custom executable + True + True + False + False + True + + + 2 + 3 + + + + + True + False + Repository + + + 1 + 2 + + + + + True + False + MergeTool + + + 1 + 2 + 5 + 6 + 5 + + + + + + + + + + + + + + True + True + ● + True + + + 2 + 3 + 5 + 6 + 5 + + + + + True + True + True + actBrowsePathToTool + True + 0.52999997138977051 + + + 3 + 4 + 5 + 6 + GTK_EXPAND + + + + + True + True + 0 + + + + + True + False + 1 + 0 + + + True + False + + + True + True + True + actCancel + + + False + False + 0 + + + + + gtk-ok + True + True + True + actOk + False + True + True + + + False + False + 1 + + + + + + + False + True + 1 + + + + + + diff --git a/data/guiSvnAskpass.glade b/data/guiSvnAskpass.glade new file mode 100644 --- /dev/null +++ b/data/guiSvnAskpass.glade @@ -0,0 +1,166 @@ + + + + + + Cancel + Cancel + gtk-cancel + + + Ok + Ok + gtk-ok + + + False + + + True + False + + + True + False + + + Use password + True + True + False + False + True + True + + + False + False + 0 + + + + + True + False + + + True + False + + + True + False + Password + + + True + True + 0 + + + + + True + True + False + • + True + False + False + True + True + + + True + True + 1 + + + + + True + True + 0 + + + + + True + True + 1 + + + + + Save for this session + True + True + False + False + True + + + True + True + 2 + + + + + True + True + 0 + + + + + True + False + 1 + 0 + + + True + False + + + True + True + True + actCancel + True + + + False + False + 0 + + + + + True + True + True + actOk + True + + + False + False + 1 + + + + + + + False + True + 5 + 1 + + + + + + diff --git a/data/guiSvnCheckout.glade b/data/guiSvnCheckout.glade new file mode 100644 --- /dev/null +++ b/data/guiSvnCheckout.glade @@ -0,0 +1,173 @@ + + + + + + + + + + + False + Checkout + 440 + 250 + + + True + False + + + True + False + + + True + False + + + True + False + URL + + + True + True + 0 + + + + + True + False + Revision + + + True + True + 1 + + + + + True + False + Path + + + True + True + 2 + + + + + False + True + 28 + 0 + + + + + True + False + + + True + True + buffer_url + + + True + True + 0 + + + + + True + True + buffer_revision + + + True + True + 1 + + + + + True + True + buffer_path + + + True + True + 2 + + + + + True + True + 1 + + + + + True + True + 0 + + + + + True + False + 1 + 0 + + + True + False + + + True + True + True + actCancel + + + False + False + 0 + + + + + True + True + True + actCheckout + + + False + False + 1 + + + + + + + False + True + 3 + + + + + + diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,174 @@ +----------------------------------------------------------------------------- +-- +-- Module : Main +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module Main ( + main +) where + +import VCSGui.Common.MergeTool +import qualified VCSGui.Svn as Svn +import qualified VCSWrapper.Common as Wrapper + +import qualified VCSGui.Git.Log as GitLog +import qualified VCSGui.Git.Commit as GitCommit +import qualified VCSGui.Mercurial.Commit as MercurialCommit +import qualified VCSGui.Mercurial.Log as MercurialLog +import Graphics.UI.Gtk +import Control.Monad.Trans(liftIO) +-- +--svn +-- + +-- +-- commit +-- + +{- +cwd = "/home/forste/svnreps/project1_work1" +main = do + initGUI + runWithConfig $ Svn.showCommitGUI eMergeToolSetter $ Left handler + mainGUI + mainQuit + where + eMergeToolSetter = Right (\tool -> putStrLn ("Setter called with " ++ fullPath tool)) + runWithConfig = Wrapper.runVcs $ Wrapper.makeConfig (Just cwd) Nothing Nothing + handler = (\result -> liftIO $ putStrLn $ show result) + +-} + +-- +-- checkout +-- + +{- +cwd = "/home/n0s/" +main = do + initGUI + runWithConfig $ Svn.showCheckoutGUI + mainGUI + mainQuit + where + runWithConfig = runVcs $ makeConfig (Just cwd) Nothing Nothing +-} + +-- +--log +-- + +{- +cwd = "/home/forste/project1_work" +main = do + initGUI + runWithConfig $ + Svn.showLogGUI + mainGUI + mainQuit + where + runWithConfig = Wrapper.runVcs $ Wrapper.makeConfig (Just cwd) Nothing Nothing +-} + +-- +--askpass +-- +--main = do +-- initGUI +-- runWithConfig $ Svn.showAskpassGUI (\result -> liftIO $ putStrLn $ "Result "++ show result) +-- mainGUI +-- mainQuit +-- where +-- runWithConfig = Wrapper.runVcs $ Wrapper.makeConfig Nothing Nothing Nothing + +-- +--git +-- + +-- +--log +-- + +cwdGit = "/home/forste/leksahWorkspace/leksah" +--cwdGit = "/home/n0s-ubuntu/testrepo" +{- +main = do + initGUI + runWithConfig $ + GitLog.showLogGUI + mainGUI + where + runWithConfig = Wrapper.runVcs $ Wrapper.makeConfig (Just cwdGit) Nothing Nothing +-} + + +-- +-- commit +-- + +{- +main = do + initGUI + runWithConfig $ + GitCommit.showCommitGUI + mainGUI + where + runWithConfig = Wrapper.runVcs $ Wrapper.makeConfig (Just cwdGit) Nothing Nothing +-} + + +-- +-- common +-- + +-- setup repo +{- +cwd = "/home/forste/svnreps/project1_work1" +main = do + initGUI + Svn.showSetupConfigGUI config $ handler + mainGUI + where + handler (Just (x, y, z)) = putStrLn $ + "Config:" ++ show y + ++ ", Chosen vcs:" ++ show x + ++ ", MergeTool:" ++ show z + handler Nothing = putStrLn "Handler got Nothing" + config = Just (Wrapper.GIT, Wrapper.makeConfig Nothing Nothing Nothing, Nothing) +-- config = Just (Wrapper.GIT, Wrapper.makeConfig (Just cwd) Nothing Nothing) +-} + + +-- +-- mercurial +-- + +cwdMercurial = "/home/forste/tmp/testvcs/hgreps/repo1" +{- +main = do + initGUI + runWithConfig $ + MercurialCommit.showCommitGUI + mainGUI + where + runWithConfig = Wrapper.runVcs $ Wrapper.makeConfig (Just cwdMercurial) Nothing Nothing +-} + +--{- +main = do + initGUI + runWithConfig $ + MercurialLog.showLogGUI + mainGUI + where + runWithConfig = Wrapper.runVcs $ Wrapper.makeConfig (Just cwdMercurial) Nothing Nothing +---} diff --git a/src/VCSGui.hs b/src/VCSGui.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui.hs @@ -0,0 +1,20 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module VCSGui ( + +) where + + + diff --git a/src/VCSGui/Common.hs b/src/VCSGui/Common.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Common.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Common +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Common gui elements and functions are declared here. +-- This module is not an exposed library, every vcs-main-module should reexport this module instead +-- +----------------------------------------------------------------------------- + +module VCSGui.Common ( + VCSGui.Common.Error.showErrorGUI + , VCSGui.Common.SetupConfig.showSetupConfigGUI + , VCSGui.Common.ExceptionHandler.defaultVCSExceptionHandler + , module VCSGui.Common.MergeTool +) where +import qualified VCSGui.Common.SetupConfig +import qualified VCSGui.Common.Error +import qualified VCSGui.Common.ExceptionHandler +import VCSGui.Common.MergeTool diff --git a/src/VCSGui/Common/Commit.hs b/src/VCSGui/Common/Commit.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Common/Commit.hs @@ -0,0 +1,192 @@ +----------------------------------------------------------------------------- +-- +-- Module : Main +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- TODO select all files checkbox + TODOs below +-- +-- | Functions to show a commit window. This mostly hides the window-building tasks from the specific VCS implementation. +----------------------------------------------------------------------------- +module VCSGui.Common.Commit ( + SCFile(..) + ,Option + ,showCommitGUI + ,selected + ,filePath + ,status + ,isLocked +) where + +import qualified VCSWrapper.Common as Wrapper +import qualified VCSGui.Common.GtkHelper as H +import Graphics.UI.Gtk +import Control.Monad.Trans(liftIO) +import Control.Monad +import Control.Monad.Reader +import Maybe +import Paths_vcsgui(getDataFileName) + +-- +-- glade path and object accessors +-- + +getGladepath = getDataFileName "data/guiCommonCommit.glade" +accessorWindowCommit = "windowCommit" +accessorTreeViewFiles = "treeViewFiles" +accessorActCommit = "actCommit" +accessorActCancel = "actCancel" +accessorActTxtViewMsg = "txtViewMsg" + +-- +-- types +-- + +-- | This function will be called after the ok action is called. +type OkCallBack = String -- ^ Commit message as specified in the GUI. + -> [FilePath] -- ^ List of 'FilePath's of the files that were selected. + -> [Option] -- ^ options (this is currently not implemented i.e. '[]' is passed) + -> Wrapper.Ctx () + +-- | fn to set listStore model for treeview +type TreeViewSetter = TreeView + -> Wrapper.Ctx (ListStore SCFile) + + +data CommitGUI = CommitGUI { + windowCommit :: H.WindowItem + , treeViewFiles :: H.TreeViewItem SCFile + , actCommit :: H.ActionItem + , actCancel :: H.ActionItem + , txtViewMsg :: H.TextViewItem +} + +-- | Represents a file which can be selected for commiting. +data SCFile = GITSCFile Bool FilePath String | + SVNSCFile Bool FilePath String Bool + deriving (Show) + +-- | Return 'True' if the 'SCFile' is flagged as selected. +selected :: SCFile -> Bool +selected (GITSCFile s _ _) = s +selected (SVNSCFile s _ _ _) = s + +-- | Return the 'FilePath' of this file. +filePath :: SCFile -> FilePath +filePath (GITSCFile _ fp _ ) = fp +filePath (SVNSCFile _ fp _ _) = fp + +-- | Return the status of this file. +status :: SCFile -> String +status (GITSCFile _ _ s) = s +status (SVNSCFile _ _ s _) = s + +-- | Return 'True' if this file is locked. For Git, this returns always 'False'. +isLocked :: SCFile -> Bool +isLocked (SVNSCFile _ _ _ l) = l +isLocked _ = False + + +-- | Options to the 'OkCallBack'. +type Option = String + + +-- | Display a window to enter a commit message and select files to be commited. +showCommitGUI :: TreeViewSetter + -> OkCallBack + -> Wrapper.Ctx() +showCommitGUI setUpTreeView okCallback = do + liftIO $ putStrLn "Starting gui ..." + gui <- loadCommitGUI setUpTreeView + + -- connect actions + liftIO $ H.registerClose $ windowCommit gui + liftIO $ H.registerCloseAction (actCancel gui) (windowCommit gui) + config <- ask + liftIO $ on (H.getItem (actCommit gui)) actionActivated $ do + let (store,_) = H.getItem (treeViewFiles gui) + selectedFiles <- getSelectedFiles store + mbMsg <- H.get (txtViewMsg gui) + case selectedFiles of + [] -> return() -- TODO err-message, selected files are empty + _ -> do + case mbMsg of + Nothing -> return() --TODO err-message, message is empty + Just msg -> Wrapper.runVcs config $ okCallback msg selectedFiles [] -- TODO implement Options + H.closeWin (windowCommit gui) + + -- present window + liftIO $ widgetShowAll $ H.getItem $ windowCommit gui + + return () + + + +loadCommitGUI :: TreeViewSetter -- ^ fn to set listStore model for treeview + -> Wrapper.Ctx CommitGUI +loadCommitGUI setUpTreeView = do + gladepath <- liftIO getGladepath + builder <- liftIO $ H.openGladeFile gladepath + + win <- liftIO $ H.getWindowFromGlade builder accessorWindowCommit + treeViewFiles <- getTreeViewFromGladeCustomStore builder accessorTreeViewFiles setUpTreeView + actCommit <- liftIO $ H.getActionFromGlade builder accessorActCommit + actCancel <- liftIO $ H.getActionFromGlade builder accessorActCancel + txtViewMsg <- liftIO $ H.getTextViewFromGlade builder accessorActTxtViewMsg + return $ CommitGUI win treeViewFiles actCommit actCancel txtViewMsg +---- +---- HELPERS +---- + +getSelectedFiles :: ListStore SCFile -> IO [FilePath] +getSelectedFiles listStore = do + listedFiles <- listStoreToList listStore + let selectedFiles = map (\scf -> filePath scf ) + $ filter (\scf -> selected scf) listedFiles + return (selectedFiles) + +getTreeViewFromGladeCustomStore :: Builder + -> String + -> TreeViewSetter + -> Wrapper.Ctx (H.TreeViewItem SCFile) +getTreeViewFromGladeCustomStore builder name setupListStore = do + (_, tView) <- liftIO $ wrapWidget builder castToTreeView name + store <- setupListStore tView + let getter = getFromListStore (store, tView) + setter = setToListStore (store, tView) + return (name, (store, tView), (getter, setter)) + +--- +--- same as gtkhelper, but avoiding exposing it +--- +wrapWidget :: GObjectClass objClass => + Builder + -> (GObject -> objClass) + -> String -> IO (String, objClass) +wrapWidget builder cast name = do + putStrLn $ " cast " ++ name + gobj <- builderGetObject builder cast name + return (name, gobj) + +getFromListStore :: (ListStore a, TreeView) + -> IO (Maybe [a]) +getFromListStore (store, _) = do + list <- listStoreToList store + if null list + then return Nothing + else return $ Just list + +setToListStore :: (ListStore a, TreeView) + -> [a] + -> IO () +setToListStore (store, view) newList = do + listStoreClear store + mapM_ (listStoreAppend store) newList + return () + + + diff --git a/src/VCSGui/Common/ConflictsResolved.hs b/src/VCSGui/Common/ConflictsResolved.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Common/ConflictsResolved.hs @@ -0,0 +1,73 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Common.ConflictsResolved +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Provides a VCS-independent GUI to ask a user if conflicts have been resolved. +-- +----------------------------------------------------------------------------- + +module VCSGui.Common.ConflictsResolved ( + showConflictsResolvedGUI +) where + +import qualified VCSWrapper.Common as Wrapper +import Paths_vcsgui(getDataFileName) +import qualified VCSGui.Common.GtkHelper as H +import Control.Monad.Trans(liftIO) +import Graphics.UI.Gtk +import Control.Monad.Reader(ask) + +-- +-- glade path and object accessors +-- + +getGladepath = getDataFileName "data/guiCommonConflictsResolved.glade" +accessorWindowConflictsResolved = "windowConflictsResolved" +accessorActConflictsResolved = "actConflictsResolved" +accessorActConflictsNotResolved = "actConflictsNotResolved" + + +data ConflictsResolvedGUI = ConflictsResolvedGUI { + windowConflictsResolved :: H.WindowItem + , actConflictsResolved :: H.ActionItem + , actConflictsNotResolved :: H.ActionItem +} + +-- | Shows a GUI asking user if conflicts have been resolved. +showConflictsResolvedGUI :: (Bool -> Wrapper.Ctx()) -- ^ Handler for user response. Argument is: True if conflicts have been resolved, False if not. + -> Wrapper.Ctx () +showConflictsResolvedGUI handler = do + liftIO $ putStrLn "Starting conflictsResolvedGUI ..." + gui <- loadConflictsResolvedGUI + + -- connect actions + liftIO $ H.registerClose $ windowConflictsResolved gui + config <- ask + liftIO $ on (H.getItem (actConflictsNotResolved gui)) actionActivated $ do + Wrapper.runVcs config $ handler False + H.closeWin (windowConflictsResolved gui) + + liftIO $ on (H.getItem (actConflictsResolved gui)) actionActivated $ do + Wrapper.runVcs config $ handler True + H.closeWin (windowConflictsResolved gui) + + -- present window + liftIO $ widgetShowAll $ H.getItem $ windowConflictsResolved gui + + return () + +loadConflictsResolvedGUI :: Wrapper.Ctx ConflictsResolvedGUI +loadConflictsResolvedGUI = do + gladepath <- liftIO getGladepath + builder <- liftIO $ H.openGladeFile gladepath + + win <- liftIO $ H.getWindowFromGlade builder accessorWindowConflictsResolved + actConflictsResolved <- liftIO $ H.getActionFromGlade builder accessorActConflictsResolved + actConflictsNotResolved <- liftIO $ H.getActionFromGlade builder accessorActConflictsNotResolved + return $ ConflictsResolvedGUI win actConflictsResolved actConflictsNotResolved diff --git a/src/VCSGui/Common/Error.hs b/src/VCSGui/Common/Error.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Common/Error.hs @@ -0,0 +1,28 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Common.Error +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Functions to handle errors are found in this module. +-- +----------------------------------------------------------------------------- + +module VCSGui.Common.Error ( + showErrorGUI +) where +import Graphics.UI.Gtk + + +-- | Displays a simple window displaying given 'String' as an error message. +showErrorGUI :: String -- ^ Message to display. + -> IO () +showErrorGUI msg = do + dialog <- messageDialogNew Nothing [] MessageError ButtonsOk msg + _ <- dialogRun dialog + widgetDestroy dialog + return () diff --git a/src/VCSGui/Common/ExceptionHandler.hs b/src/VCSGui/Common/ExceptionHandler.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Common/ExceptionHandler.hs @@ -0,0 +1,36 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Common.ExceptionHandler +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Exception handling functions can be found in this module. +-- +----------------------------------------------------------------------------- + +module VCSGui.Common.ExceptionHandler ( + defaultVCSExceptionHandler +) where + +import qualified Control.Exception as Exc + +import VCSWrapper.Common +import VCSGui.Common.Error + + +-- | Wraps an IO computation to display an error message if a 'VCSException' occurs. +defaultVCSExceptionHandler :: IO t -> IO () +defaultVCSExceptionHandler vcsRunner = do + o <- Exc.try vcsRunner + putStrLn $ "exception handler called" + case o of + Left (VCSException exitCode out err repoLocation (cmd:opts)) -> do + putStrLn $ "exception caught" + showErrorGUI $ unlines ["An error occured.", err, "Details:", "command: " ++ cmd, "options: " ++ unwords opts] + Right _ -> do + putStrLn $ "no exception" + return () diff --git a/src/VCSGui/Common/FilesInConflict.hs b/src/VCSGui/Common/FilesInConflict.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Common/FilesInConflict.hs @@ -0,0 +1,262 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Common.FilesInConflict +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Provides a GUI to show and resolve conflicts in a VCS. +-- +----------------------------------------------------------------------------- + +module VCSGui.Common.FilesInConflict ( + showFilesInConflictGUI +) where + +import qualified VCSWrapper.Common as Wrapper +import qualified VCSGui.Common.GtkHelper as H +import qualified VCSGui.Common.Commit as Commit +import qualified VCSGui.Common.MergeTool as Merge +import qualified VCSGui.Common.Process as Process +import qualified VCSGui.Common.ConflictsResolved as ConflictsResolvedGUI +import qualified VCSGui.Common.Error as Error +import Graphics.UI.Gtk +import Control.Monad.Trans(liftIO) +import Control.Monad +import Control.Monad.Reader +import Paths_vcsgui(getDataFileName) + +-- +-- glade path and object accessors +-- + +getGladepath = getDataFileName "data/guiCommonFilesInConflict.glade" +accessorWindowFilesInConflict = "windowFilesInConflict" +accessorTreeViewFiles = "treeViewFiles" +accessorActResolved = "actResolved" +accessorActCancel = "actCancel" +accessorActBrowsePath = "actBrowsePath" +accessorEntPath = "entPath" + +-- +-- types +-- + +-- | Handler being called after all files have been resolved and resolved button is pressed +type Handler = Wrapper.Ctx() + +-- fn to set listStore model for treeview +type TreeViewSetter = (Maybe FilePath) -- ^ Maybe cwd + -> [FilePath] -- ^ conflicting files + -> (FilePath -> Wrapper.Ctx [FilePath]) -- ^ fn receiving a path to a conflicting file and returning all conflicting files involved in the conflict (max 4) + -> (FilePath -> Wrapper.Ctx ()) -- ^ fn to mark files as resolved in VCS + -> (Either Merge.MergeTool Merge.MergeToolSetter) -- ^ either a mergetool or fn to set one + -> H.TextEntryItem -- ^ the entry to get the path to the mergetool from + -> TreeView -- ^ the treeview to set the model to + -> Wrapper.Ctx (ListStore SCFile) + +-- GUI storing accessible elements +data GUI = GUI { + windowFilesInConflict :: H.WindowItem + , treeViewFiles :: H.TreeViewItem SCFile + , actResolved :: H.ActionItem + , actCancel :: H.ActionItem + , actBrowsePath :: H.ActionItem + , entPath :: H.TextEntryItem +} + +--model for treestore +data SCFile = SCFile { + filePath :: FilePath + , isResolved :: Bool + } + deriving (Show) + + +-- | Shows a GUI showing conflicting files and providing means to resolve the conflicts. +showFilesInConflictGUI :: (Maybe TreeViewSetter) -- ^ fn to set listStore model for treeview, Nothing for default + -> [FilePath] -- ^ conflicting files + -> (FilePath -> Wrapper.Ctx [FilePath]) -- ^ fn receiving a path to a conflicting file and returning all conflicting files involved in the conflict (max 4) + -> (FilePath -> Wrapper.Ctx ()) -- ^ fn to mark files as resolved in VCS + -> (Either Merge.MergeTool Merge.MergeToolSetter) -- ^ 'MergeTool' is used for any possible conflicts. If not present user will be asked to provide 'MergeTool' on conflicts. 'MergeToolSetter' will be called for response. + -> Handler -- ^ 'Handler' for action resolved + -> Wrapper.Ctx () +showFilesInConflictGUI Nothing f g m e a = + showFilesInConflictGUI (Just defaultSetUpTreeView) f g m e a +showFilesInConflictGUI (Just setUpTreeView) filesInConflict filesToResolveGetter resolveMarker eMergeToolSetter actResolvedHandler = do + liftIO $ putStrLn "Starting files in conflict gui ..." + config <- ask + let cwd = (Wrapper.configCwd config) + gui <- loadGUI $ setUpTreeView cwd filesInConflict filesToResolveGetter resolveMarker eMergeToolSetter + mbMergeToolSetter <- case eMergeToolSetter of + Left (Merge.MergeTool path) -> do + liftIO $ H.set (entPath gui) path + return Nothing + Right setter -> return $ Just setter + + -- connect actions + liftIO $ H.registerClose $ windowFilesInConflict gui + liftIO $ H.registerCloseAction (actCancel gui) (windowFilesInConflict gui) + config <- ask + liftIO $ on (H.getItem (actResolved gui)) actionActivated $ do + --TODO check if all files have been resolved + Wrapper.runVcs config $ actResolvedHandler + H.closeWin (windowFilesInConflict gui) + liftIO $ on (H.getItem (actBrowsePath gui)) actionActivated $ do + mbPath <- showFolderChooserDialog "Select executable" (H.getItem $ windowFilesInConflict gui) FileChooserActionOpen + case mbPath of + Nothing -> return () + Just path -> do + -- update gui + H.set (entPath gui) path + -- call setter + case mbMergeToolSetter of + Nothing -> return () + Just setter -> setter (Merge.MergeTool path) + return () + -- present window + liftIO $ widgetShowAll $ H.getItem $ windowFilesInConflict gui + + return () + +loadGUI :: (H.TextEntryItem -> TreeView -> Wrapper.Ctx (ListStore SCFile)) + -- ^ (The entry to get the path to the mergetool from. , treeview to setup, fn to set listStore model for treeview + -> Wrapper.Ctx GUI +loadGUI setUpTreeView = do + gladepath <- liftIO getGladepath + builder <- liftIO $ H.openGladeFile gladepath + + win <- liftIO $ H.getWindowFromGlade builder accessorWindowFilesInConflict + entPath <- liftIO $ H.getTextEntryFromGlade builder accessorEntPath + treeViewFiles <- getTreeViewFromGladeCustomStore builder accessorTreeViewFiles (setUpTreeView entPath) + actResolved <- liftIO $ H.getActionFromGlade builder accessorActResolved + actCancel <- liftIO $ H.getActionFromGlade builder accessorActCancel + actBrowsePath <- liftIO $ H.getActionFromGlade builder accessorActBrowsePath + return $ GUI win treeViewFiles actResolved actCancel actBrowsePath entPath + +defaultSetUpTreeView :: TreeViewSetter +defaultSetUpTreeView mbcwd conflictingFiles filesToResolveGetter resolveMarker eMergeToolSetter entPath listView = do + config <- ask + liftIO $ do + -- create model + listStore <- listStoreNew [ + (SCFile fileName + (False)) + | fileName <- conflictingFiles] + treeViewSetModel listView listStore + + let treeViewItem = (listStore, listView) + + renderer <- cellRendererTextNew + H.addColumnToTreeView' treeViewItem + renderer + "File" + $ \scf -> [cellText := filePath scf] + + renderer <- cellRendererToggleNew + H.addColumnToTreeView' treeViewItem + renderer + "Resolved" + $ \scf -> [cellToggleActive := isResolved scf] + + -- connect select action + on renderer cellToggled $ \columnId -> do + putStrLn $ "Checkbutton clicked at column " ++ (show columnId) + --TODO only call tool if button is not checked, move this code to being called if a click on row is received + let callTool' = (\path -> Wrapper.runVcs config $ callTool columnId listStore path) + mbPath <- H.get entPath + case mbPath of + Nothing -> Error.showErrorGUI "MergeTool not set. Set MergeTool first." + Just path -> callTool' path + return () + + + return listStore + where + callTool columnId listStore pathToTool = do + config <- ask + Just treeIter <- liftIO $ treeModelGetIterFromString listStore columnId + value <- liftIO $ listStoreGetValue listStore $ listStoreIterToIndex treeIter + filesToResolve <- filesToResolveGetter $ filePath value + resolvedByTool <- liftIO $ Process.exec mbcwd pathToTool filesToResolve + let setResolved' = setResolved listStore treeIter value + case resolvedByTool of + False -> ConflictsResolvedGUI.showConflictsResolvedGUI + (\resolved -> setResolved' resolved) + True -> setResolved listStore treeIter value True + return() + setResolved listStore treeIter oldValue isResolved = do + let fp = filePath oldValue + case isResolved of + False -> return () + True -> resolveMarker fp + let newValue = (\(SCFile fp b) -> SCFile fp isResolved) + oldValue + liftIO $ listStoreSetValue listStore (listStoreIterToIndex treeIter) newValue + return () + +---- +---- HELPERS +---- + +getTreeViewFromGladeCustomStore :: Builder + -> String + -> (TreeView -> Wrapper.Ctx (ListStore SCFile)) -- ^ fn defining how to setup the liststore + -> Wrapper.Ctx (H.TreeViewItem SCFile) +getTreeViewFromGladeCustomStore builder name setupListStore = do + (_, tView) <- liftIO $ wrapWidget builder castToTreeView name + store <- setupListStore tView + let getter = getFromListStore (store, tView) + setter = setToListStore (store, tView) + return (name, (store, tView), (getter, setter)) + +--- +--- same as gtkhelper, but avoiding exposing it +--- +wrapWidget :: GObjectClass objClass => + Builder + -> (GObject -> objClass) + -> String -> IO (String, objClass) +wrapWidget builder cast name = do + putStrLn $ " cast " ++ name + gobj <- builderGetObject builder cast name + return (name, gobj) + +getFromListStore :: (ListStore a, TreeView) + -> IO (Maybe [a]) +getFromListStore (store, _) = do + list <- listStoreToList store + if null list + then return Nothing + else return $ Just list + +setToListStore :: (ListStore a, TreeView) + -> [a] + -> IO () +setToListStore (store, view) newList = do + listStoreClear store + mapM_ (listStoreAppend store) newList + return () + +-- HELPER + +-- | shows a dialog to choose a folder, returns Just FilePath to folder if succesfull, Nothing if cancelled +showFolderChooserDialog :: String -- ^ title of the window + -> Window -- ^ parent window + -> FileChooserAction + -> IO (Maybe FilePath) +showFolderChooserDialog title parent fcAction = do + dialog <- fileChooserDialogNew (Just title) (Just parent) fcAction [("Cancel", ResponseCancel), ("Select", ResponseAccept)] + response <- dialogRun dialog + case response of + ResponseCancel -> widgetDestroy dialog >> return Nothing + ResponseDeleteEvent -> widgetDestroy dialog >> return Nothing + ResponseAccept -> do + f <- fileChooserGetFilename dialog + widgetDestroy dialog + return f + + diff --git a/src/VCSGui/Common/GtkHelper.hs b/src/VCSGui/Common/GtkHelper.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Common/GtkHelper.hs @@ -0,0 +1,348 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Common.GtkHelper +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | This module contains functions to help building a GTK GUI using GTKBuilder. +-- +----------------------------------------------------------------------------- + +module VCSGui.Common.GtkHelper ( +-- * Typesynonyms to wrap Gtk objects (*Item) +-- +-- | These are built after the following scheme: +-- +-- @((Name of the item as in the gladefile), (actual gtk object), (getter, setter))@ +-- +-- Note however that you can (and should) use the functions 'getName', 'getItem', 'get' and 'set'. + + openGladeFile + , getWindowFromGlade + , getActionFromGlade + , getLabelFromGlade + , getTextEntryFromGlade + , getTextViewFromGlade + , getComboBoxFromGlade + , getCheckButtonFromGlade + , getButtonFromGlade + , getTreeViewFromGlade + , getTreeViewFromGladeCustomStore + , addColumnToTreeView + , addColumnToTreeView' + , addTextColumnToTreeView + , addTextColumnToTreeView' + + + , getName + , getItem + , get + , set + + , closeWin + , registerClose + , registerCloseAction + , registerQuit + , registerQuitAction + + , WindowItem + , ActionItem + , LabelItem + , TextEntryItem + , TextViewItem + , ComboBoxItem + , CheckButtonItem + , TreeViewItem + , ButtonItem +) where + +import qualified Graphics.UI.Gtk as Gtk + +import System.Directory +import Control.Monad.Trans(liftIO) +import System.IO (hPutStrLn, stderr) +import VCSGui.Common.Helpers (emptyListToNothing) + +-- Typesynonyms +type WindowItem = (String, Gtk.Window, ()) +type ActionItem = (String, Gtk.Action, ()) +type LabelItem = (String, Gtk.Label, (IO (Maybe String), String -> IO ())) +type TextEntryItem = (String, Gtk.Entry, (IO (Maybe String), String -> IO ())) +type ComboBoxItem = (String, Gtk.ComboBox, (IO (Maybe String), [String] -> IO ())) +type TextViewItem = (String, Gtk.TextView, (IO (Maybe String), String -> IO ())) +type TreeViewItem a = (String, (Gtk.ListStore a, Gtk.TreeView), (IO (Maybe [a]), [a] -> IO ())) +type CheckButtonItem = (String, Gtk.CheckButton, (IO Bool, Bool -> IO())) +type ButtonItem = (String, Gtk.Button, (IO String, String -> IO())) + +-- Type accessors + +-- | return the name of this item (as in the gladefile) +getName :: (String, a, b) -> String +getName (n, _, _) = n + +-- | return the Gtk object wrapped by given item +getItem :: (String, a, b) -> a +getItem (_, item, _) = item + +-- | call teh get method of an *Item +get :: (String, a, (b, c)) -> b +get (_, _, (getter, _)) = getter + +-- | call the set method of an *Item +set :: (String, a, (b, c)) -> c +set (_,_, (_, setter)) = setter + + +---------------------- +-- *FromGlade +---------------------- + +-- | Open a gladefile with a new 'Gtk.Builder'. +openGladeFile :: FilePath -- ^ Gladefile to open. + -> IO Gtk.Builder +openGladeFile fn = do + builder <- Gtk.builderNew + Gtk.builderAddFromFile builder fn + return builder + +-- | Get a 'WindowItem' from a gladefile. +getWindowFromGlade :: Gtk.Builder + -> String -- ^ name of the window to get as specified in the gladefile. + -> IO WindowItem +getWindowFromGlade builder name = do + (a, b) <- wrapWidget builder Gtk.castToWindow name + return (a, b, ()) + +-- | Get an 'ActionItem' from a gladefile. +getActionFromGlade :: Gtk.Builder + -> String -- ^ name of the action to get as specified in the gladefile. + -> IO ActionItem +getActionFromGlade builder name = do + (a, b) <- wrapWidget builder Gtk.castToAction name + return (a, b, ()) + +-- | Get an 'LabelItem' from a gladefile. +getLabelFromGlade :: Gtk.Builder + -> String -- ^ name of the label to get as specified in the gladefile. + -> IO LabelItem +getLabelFromGlade builder name = do + (_, entry) <- wrapWidget builder Gtk.castToLabel name + let getter = error "don't call get on a gtk label!" :: IO (Maybe String) + setter val = Gtk.labelSetText entry val :: IO () + return (name, entry, (getter, setter)) + +-- | Get a 'ButtonItem' from a gladefile. +getButtonFromGlade :: Gtk.Builder + -> String -- ^ name of the button to get as specified in the gladefile. + -> IO ButtonItem +getButtonFromGlade builder name = do + (_,btn) <- wrapWidget builder Gtk.castToButton name + let getter = Gtk.buttonGetLabel btn :: IO String + setter val = Gtk.buttonSetLabel btn val + return (name, btn, (getter,setter)) + +-- | Get a 'TextEntryItem' from a gladefile. +getTextEntryFromGlade :: Gtk.Builder + -> String -- ^ name of the text entry to get as specified in the gladefile. + -> IO TextEntryItem +getTextEntryFromGlade builder name = do + (_, entry) <- wrapWidget builder Gtk.castToEntry name + let getter = fmap emptyListToNothing $ Gtk.entryGetText entry :: IO (Maybe String) + setter val = Gtk.entrySetText entry val :: IO () + return (name, entry, (getter, setter)) + +-- | Get a 'ComboBoxItem' from a gladefile. +getComboBoxFromGlade :: Gtk.Builder + -> String -- ^ name of the combo box to get as specified in the gladefile. + -> IO ComboBoxItem +getComboBoxFromGlade builder name = do + (_, combo) <- wrapWidget builder Gtk.castToComboBox name + Gtk.comboBoxSetModelText combo + let getter = Gtk.comboBoxGetActiveText combo :: IO (Maybe String) -- get selected text + setter entries = do -- fill with new entries + store <- Gtk.comboBoxGetModelText combo + Gtk.listStoreClear store + mapM_ (Gtk.listStoreAppend store) entries + return () + return (name, combo, (getter, setter)) + +-- | Get a 'TextViewItem' from a gladefile. +getTextViewFromGlade :: Gtk.Builder + -> String -- ^ name of the text view to get as specified in the gladefile. + -> IO TextViewItem +getTextViewFromGlade builder name = do + (_, entry) <- wrapWidget builder Gtk.castToTextView name + buffer <- Gtk.textViewGetBuffer entry + let getter = getLongText buffer :: IO (Maybe String) + setter = (\text -> Gtk.textBufferSetText buffer text) :: String -> IO () + return (name, entry, (getter, setter)) + where + getLongText buffer = do + start <- Gtk.textBufferGetStartIter buffer + end <- Gtk.textBufferGetEndIter buffer + isEmpty <- (Gtk.textIterEqual start end) + if isEmpty then return Nothing else do + s <- Gtk.textBufferGetText buffer start end True -- True to inclue hidden char + return $ Just s + +-- | Get a 'CheckButtonItem' from a gladefile. +getCheckButtonFromGlade :: Gtk.Builder + -> String -- ^ name of the check button to get as specified in the gladefile. + -> IO CheckButtonItem +getCheckButtonFromGlade builder name = do + (_,bt) <- wrapWidget builder Gtk.castToCheckButton name + let getter = Gtk.toggleButtonGetActive bt + setter = (\bool -> Gtk.toggleButtonSetActive bt bool) :: Bool -> IO() + return (name,bt, (getter,setter)) + +--------------------------------- +-- TreeView +--------------------------------- + +-- | Get a 'TreeViewItem' from a gladefile. +getTreeViewFromGlade :: Gtk.Builder + -> String -- ^ name of the tree view to get as specified in the gladefile. + -> [a] -- ^ Content of the new tree view. + -> IO (TreeViewItem a) +getTreeViewFromGlade builder name rows = do + (_, tView) <- wrapWidget builder Gtk.castToTreeView name + entry@(store, treeView) <- createStoreForTreeView tView rows + let getter = getFromListStore entry + setter = setToListStore entry + return (name, (store, treeView), (getter, setter)) + +-- | Get a 'TreeViewItem' from a gladefile. +getTreeViewFromGladeCustomStore :: Gtk.Builder + -> String -- ^ name of the tree view to get as specified in the gladefile. + -> (Gtk.TreeView -> IO (Gtk.ListStore a)) -- ^ fn defining how to setup the liststore + -> IO (TreeViewItem a) +getTreeViewFromGladeCustomStore builder name setupListStore = do + (_, tView) <- wrapWidget builder Gtk.castToTreeView name + store <- setupListStore tView + Gtk.treeViewSetModel tView store + let getter = getFromListStore (store, tView) + setter = setToListStore (store, tView) + return (name, (store, tView), (getter, setter)) + +-- | Create a new 'Gtk.ListStore' for a 'Gtk.TreeView'. +createStoreForTreeView :: Gtk.TreeView -- ^ The created list store will be set the model for this TreeView. + -> [a] -- ^ Content of the new store. + -> IO (Gtk.ListStore a, Gtk.TreeView) +createStoreForTreeView listView rows = do + listStore <- Gtk.listStoreNew rows + Gtk.treeViewSetModel listView listStore + return (listStore, listView) + +-- | Get the content of a ListStore. +getFromListStore :: (Gtk.ListStore a, Gtk.TreeView) + -> IO (Maybe [a]) -- ^ Nothing if the ListStore is empty. +getFromListStore (store, _) = do + list <- Gtk.listStoreToList store + if null list + then return Nothing + else return $ Just list + +-- | Set the content of a ListStore. +setToListStore :: (Gtk.ListStore a, Gtk.TreeView) + -> [a] -- ^ New content of the ListStore. + -> IO () +setToListStore (store, view) newList = do + Gtk.listStoreClear store + mapM_ (Gtk.listStoreAppend store) newList + return () + +-- +-- Various helpers +-- + +-- | Close a window. +closeWin :: WindowItem -> IO () +closeWin win = (Gtk.widgetHideAll (getItem win)) + +-- | Close a window if 'Gtk.deleteEvent' occurs on this 'WindowItem'. +registerClose :: WindowItem -> IO () +registerClose win = Gtk.on (getItem win) Gtk.deleteEvent (liftIO (closeWin win) >> return False) >> return () + +-- | Close a window if the specified action occurs on this 'WindowItem'. +registerCloseAction :: ActionItem -> WindowItem -> IO () +registerCloseAction act win = Gtk.on (getItem act) Gtk.actionActivated (liftIO (closeWin win)) >> return () + +-- | Call 'Gtk.mainQuit' if 'Gtk.deleteEvent' occurs on this 'WindowItem'. +registerQuit :: WindowItem -> IO () +registerQuit win = Gtk.on (getItem win) Gtk.deleteEvent (liftIO $ Gtk.mainQuit >> return False) >> return () + +-- | Call 'Gtk.mainQuit' if the specified action occurs on this 'WindowItem'. +registerQuitAction :: ActionItem -> IO () +registerQuitAction act = Gtk.on (getItem act) Gtk.actionActivated (liftIO (Gtk.mainQuit)) >> return () + +-- TODO fun argument is not used. what was the purpos of this function? +-- | same as 'registerQuitAction' since second argument is ignored (?) +registerQuitWithCustomFun :: WindowItem + -> IO () -- ^ custom fun + -> IO () +registerQuitWithCustomFun win fun = Gtk.on (getItem win) Gtk.deleteEvent (liftIO $ Gtk.mainQuit >> return False) >> return () + +-- | Add a column to given ListStore and TreeView using a mapping. +-- The mapping consists of a CellRenderer, the title and a function, that maps each row to attributes of the column +addColumnToTreeView :: Gtk.CellRendererClass r => + TreeViewItem a + -> r -- ^ CellRenderer + -> String -- ^ title + -> (a -> [Gtk.AttrOp r]) -- ^ mapping + -> IO () +addColumnToTreeView (_, item, _) = do + addColumnToTreeView' item +-- newCol <- Gtk.treeViewColumnNew +-- Gtk.set newCol [Gtk.treeViewColumnTitle Gtk.:= title] +-- Gtk.treeViewAppendColumn listView newCol +-- Gtk.treeViewColumnPackStart newCol renderer True +-- Gtk.cellLayoutSetAttributes newCol renderer listStore value2attributes + +-- | Same as 'addColumnToTreeView'. This function can be called without a complete 'TreeViewItem'. +addColumnToTreeView' :: Gtk.CellRendererClass r => + (Gtk.ListStore a, Gtk.TreeView) + -> r + -> String + -> (a -> [Gtk.AttrOp r]) + -> IO () +addColumnToTreeView' (listStore, listView) renderer title value2attributes = do + newCol <- Gtk.treeViewColumnNew + Gtk.set newCol [Gtk.treeViewColumnTitle Gtk.:= title] + Gtk.treeViewAppendColumn listView newCol + Gtk.treeViewColumnPackStart newCol renderer True + Gtk.cellLayoutSetAttributes newCol renderer listStore value2attributes + +-- | Shortcut for adding text columns to a TreeView. See 'addColumnToTreeView'. +addTextColumnToTreeView :: TreeViewItem a + -> String -- ^ title + -> (a -> [Gtk.AttrOp Gtk.CellRendererText]) -- ^ mapping + -> IO () +addTextColumnToTreeView tree title map = do + r <- Gtk.cellRendererTextNew + addColumnToTreeView tree r title map + +-- | Shortcut for adding text columns to a TreeView. See 'addColumnToTreeView\''. +addTextColumnToTreeView' :: (Gtk.ListStore a, Gtk.TreeView) + -> String + -> (a -> [Gtk.AttrOp Gtk.CellRendererText]) + -> IO () +addTextColumnToTreeView' item title map = do + r <- Gtk.cellRendererTextNew + addColumnToTreeView' item r title map + +--------------------------- +-- internal helpers +--------------------------- + +wrapWidget :: Gtk.GObjectClass objClass => + Gtk.Builder + -> (Gtk.GObject -> objClass) + -> String -> IO (String, objClass) +wrapWidget builder cast name = do + hPutStrLn stderr $ " cast " ++ name + gobj <- Gtk.builderGetObject builder cast name + return (name, gobj) diff --git a/src/VCSGui/Common/Helpers.hs b/src/VCSGui/Common/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Common/Helpers.hs @@ -0,0 +1,22 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Common.Helpers +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL Nothing +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module VCSGui.Common.Helpers ( + emptyListToNothing +) where + +-- | Return 'Nothing' if given list is empty, 'Just' the list otherwise. +emptyListToNothing :: [a] -> Maybe [a] +emptyListToNothing [] = Nothing +emptyListToNothing l = Just l diff --git a/src/VCSGui/Common/Log.hs b/src/VCSGui/Common/Log.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Common/Log.hs @@ -0,0 +1,181 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Common.Log +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Functions to show a log window. This mostly hides the window-building tasks from the specific VCS implementation. +-- +----------------------------------------------------------------------------- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module VCSGui.Common.Log ( + showLogGUI +) where + +import Control.Monad.Reader +import qualified Graphics.UI.Gtk as Gtk +import Data.Maybe + +import VCSGui.Common.GtkHelper +import qualified VCSWrapper.Common as Common + + +import Data.Maybe (fromMaybe) +import Paths_vcsgui(getDataFileName) + +getGladepath = getDataFileName "data/guiCommonLog.glade" + +data LogConfig a = LogConfig { + options :: [String] + ,treeViewSetter :: Gtk.TreeView -> TreeViewItem a +} + + +-------------------------------------------------- +---- LOG VIEWER / CHECKOUT +-------------------------------------------------- + +data LogGUI = LogGUI { + logWin :: WindowItem + , logTreeView :: TreeViewItem Common.LogEntry + , lblRevisionDetails :: LabelItem + , actCheckout :: ActionItem + , actLogCancel :: ActionItem + , comboBranch :: ComboBoxItem + , lblBranch :: LabelItem +} + +-- | Show the history of a repository. +showLogGUI :: [Common.LogEntry] + -- ^ logEntries to be displayed initially + -> [String] + -- ^ options will be displayed in a menu as checkboxes (TODO this is currently not implemented) + -> Maybe ((String, [String]), (String -> Common.Ctx [Common.LogEntry])) + -- ^ (list of branchnames to display, Function called when a different branch is selected) + -- + -- The function will be called with the selected branchname to repopulate the displayed LogEntries. + -- If 'Nothing', no branch selection will be displayed. + -> (Common.LogEntry -> Maybe String -> Common.Ctx ()) + -- ^ (selected line, name of the branch to checkout from) + -- + -- This function is called on checkout action. The window will be closed afterwards. + -> Bool -- ^ Add column to display branch name + -> Common.Ctx () +showLogGUI logEntries options Nothing doCheckoutFn displayBranchNames = guiWithoutBranches logEntries options doCheckoutFn displayBranchNames >> return () +showLogGUI logEntries options (Just (branches, changeBranchFn)) doCheckoutFn displayBranchNames = do + gui <- guiWithoutBranches logEntries options doCheckoutFn displayBranchNames + guiAddBranches gui branches changeBranchFn + return () + +guiWithoutBranches :: [Common.LogEntry] + -> [String] + -> (Common.LogEntry + -> (Maybe String) + -> Common.Ctx ()) + -> Bool -- ^ Add column to display branch name + -> Common.Ctx LogGUI +guiWithoutBranches logEntries options doCheckoutFn displayBranchNames = do + gui <- loadLogGui logEntries + liftIO $ setupLogColumns gui displayBranchNames + + -- connect gui elements + liftIO $ registerClose $ logWin gui + liftIO $ registerCloseAction (actLogCancel gui) (logWin gui) + + config <- ask + liftIO $ Gtk.on (getItem (actCheckout gui)) Gtk.actionActivated $ + doCheckout' config (logTreeView gui) (comboBranch gui) + >> (closeWin (logWin gui)) + + -- show window + liftIO $ Gtk.widgetShowAll $ getItem $ logWin gui + return gui + where + doCheckout' :: Common.Config -> TreeViewItem Common.LogEntry -> ComboBoxItem -> IO () + doCheckout' cfg (_, (store, view), _) combo = do + (path, _) <- Gtk.treeViewGetCursor view -- TODO fix nothing selected bug here + Just treeIter <- Gtk.treeModelGetIter store path + selectedLog <- Gtk.listStoreGetValue store $ Gtk.listStoreIterToIndex treeIter + selectedBranch <- get combo + Common.runVcs cfg $ doCheckoutFn selectedLog selectedBranch + + setupLogColumns :: LogGUI -> Bool -> IO () + setupLogColumns gui displayBranchNames = do + let item = (logTreeView gui) + addTextColumnToTreeView item "Subject" (\Common.LogEntry { Common.subject = t } -> [Gtk.cellText Gtk.:= t]) + addTextColumnToTreeView item "Author" (\Common.LogEntry { Common.author = t, Common.email = mail } -> [Gtk.cellText Gtk.:= (t ++ " <" ++ mail ++ ">")]) + addTextColumnToTreeView item "Date" (\Common.LogEntry { Common.date = t } -> [Gtk.cellText Gtk.:= t]) + case displayBranchNames of + True -> addTextColumnToTreeView item "Branch" (\Common.LogEntry { Common.mbBranch = t } -> [Gtk.cellText Gtk.:= (fromMaybe "" t)]) + False -> return() + return () + +guiAddBranches :: LogGUI -> (String, [String]) -> (String -> Common.Ctx [Common.LogEntry]) -> Common.Ctx () +guiAddBranches gui (curBranch, otherBranches) changeBranchFn = do + -- set branch selection visible + liftIO $ Gtk.set (getItem $ lblBranch gui) [Gtk.widgetVisible Gtk.:= True] + liftIO $ Gtk.set (getItem $ comboBranch gui) [Gtk.widgetVisible Gtk.:= True] + + -- fill with data + liftIO $ set (comboBranch gui) otherBranches + liftIO $ Gtk.comboBoxPrependText (getItem $ comboBranch gui) curBranch + liftIO $ Gtk.comboBoxSetActive (getItem $ comboBranch gui) 0 + + -- register branch switch fn + config <- ask + liftIO $ Gtk.on (getItem $ comboBranch gui) Gtk.changed $ changeBranchFn' config (fmap (fromMaybe "") $ get $ comboBranch gui) + return () + where + changeBranchFn' :: Common.Config -> IO String -> IO () + changeBranchFn' cfg branchIO = do + let (store, view) = getItem $ logTreeView gui + branch <- branchIO + newLogEntries <- Common.runVcs cfg $ changeBranchFn branch + set (logTreeView gui) newLogEntries + -- set cursor to first log entry (so checkoutbutton works) + Just firstRowIter <- Gtk.treeModelGetIterFirst store + firstRow <- Gtk.treeModelGetPath store firstRowIter + Gtk.treeViewSetCursor view firstRow Nothing + + +loadLogGui :: [Common.LogEntry] -> Common.Ctx LogGUI +loadLogGui logEntries = do + liftIO $ do + gladepath <- getGladepath + builder <- openGladeFile gladepath + win <- getWindowFromGlade builder "logWindow" + revDetails <- getLabelFromGlade builder "lblRevisionDetails" + actCheck <- getActionFromGlade builder "actCheckout" + actCanc <- getActionFromGlade builder "actCancel" + comboBranch <- getComboBoxFromGlade builder "comboBranch" + lblBranch <- getLabelFromGlade builder "lblBranch" + + treeView <- getTreeViewFromGlade builder "historyTreeView" logEntries + return $ LogGUI win treeView revDetails actCheck actCanc comboBranch lblBranch + + + + + + + + + + + + + + + + + + + + + + + diff --git a/src/VCSGui/Common/MergeTool.hs b/src/VCSGui/Common/MergeTool.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Common/MergeTool.hs @@ -0,0 +1,30 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Common.MergeTool +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Types associated with resolving conflicts with a 'Mergetool'. +-- +----------------------------------------------------------------------------- +{-# LANGUAGE DeriveDataTypeable #-} +module VCSGui.Common.MergeTool ( + MergeTool (..) + , MergeToolSetter + +) where + + +-- | Representation of a mergetool, e.g. kdiff3 +data MergeTool = MergeTool { + fullPath :: FilePath + } deriving (Show, Read) + +-- | Fn to set a 'MergeTool'. +type MergeToolSetter = MergeTool -> IO() + + diff --git a/src/VCSGui/Common/Process.hs b/src/VCSGui/Common/Process.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Common/Process.hs @@ -0,0 +1,68 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Common.Process +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Provides facilites to execute an external program. +-- +----------------------------------------------------------------------------- + +module VCSGui.Common.Process ( + exec +) where + +import System.Process +import System.Exit +import System.IO (Handle, hFlush, hClose, hGetContents, hPutStr) +import Control.Concurrent +import Control.Monad.Reader +import qualified Control.Exception as Exc + +-- | Internal function to execute a vcs command +exec :: Maybe FilePath -- ^ working directory or Nothing if not set + -> String -- ^ mergetool command, e.g. kdiff3.sh + -> [String] -- ^ files, last one is output + -> IO Bool +exec mcwd cmd opts = do + (ec, out, err) <- readProc mcwd cmd opts + case ec of + ExitSuccess -> return $ True + ExitFailure i -> return $ False -- Left $ Exception i out err (cmd : opts) + +-- | same as readProcessWithExitCode but having a configurable cwd and env, +readProc :: Maybe FilePath --working directory or Nothing if not set + -> String --command + -> [String] -- ^ files, last one is output + -> IO (ExitCode, String, String) +readProc mcwd cmd files = do + putStrLn $ "Executing process, mcwd: "++show mcwd++"cmd: "++show cmd++",files: "++show files + (_, Just outh, Just errh, pid) <- createProcess (proc cmd files) + { std_out = CreatePipe, + std_err = CreatePipe, + cwd = mcwd + } + + outMVar <- newEmptyMVar + + out <- hGetContents outh + _ <- forkIO $ Exc.evaluate (length out) >> putMVar outMVar () + + err <- hGetContents errh + _ <- forkIO $ Exc.evaluate (length err) >> putMVar outMVar () + +-- hClose inh + + takeMVar outMVar + takeMVar outMVar + hClose outh + hClose errh + + ex <- waitForProcess pid + return (ex, out, err) + + diff --git a/src/VCSGui/Common/SetupConfig.hs b/src/VCSGui/Common/SetupConfig.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Common/SetupConfig.hs @@ -0,0 +1,337 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Common.SetupConfig +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Module for displaying configuration dialogs. +-- +----------------------------------------------------------------------------- + +module VCSGui.Common.SetupConfig ( + showSetupConfigGUI +) where +import Graphics.UI.Gtk hiding (set, get) +import Control.Monad.Trans(liftIO) +import Data.Maybe +import Monad +import Directory +import System.Directory(doesDirectoryExist) +import Data.List.Utils(elemRIndex) +import Data.List(isInfixOf) +import Paths_vcsgui(getDataFileName) + +import VCSGui.Common.Error +import qualified VCSGui.Common.GtkHelper as H +import qualified VCSGui.Common.MergeTool as MergeTool +import qualified VCSWrapper.Common as Wrapper + +type Config = Maybe (Wrapper.VCSType, Wrapper.Config, Maybe MergeTool.MergeTool) + --config for setting up vcs + +type Callback = (Config -> IO ()) + +getGladepath = getDataFileName "data/guiCommonSetupRepo.glade" + +accessorWindowSetupRepo = "windowSetupRepo" +accessorActOk = "actOk" +accessorActCancel = "actCancel" +accessorActBrowseRepo = "actBrowseRepo" +accessorActBrowseExec = "actBrowseExec" +accessorEntRepo = "entRepo" +accessorEntExec = "entExec" +accessorEntAuthor = "entAuthor" +accessorEntEmail = "entEmail" +accessorEntComboBoxVCSType = "comboBoxVCSType" +accessorCheckbtExec = "checkbtExec" +accessorCheckbtAuthor = "checkbtAuthor" +accessorLblExec = "lblExec" +accessorBtnBrowseExec = "btnBrowseExec" +accessorLblAuthor = "lblAuthor" +accessorLblEmail = "lblEmail" +accessorActBrowsePathToTool = "actBrowsePathToTool" +accessorentPathToTool= "entPathToTool" + + +data SetupRepoGUI = SetupRepoGUI { + winSetupRepo :: H.WindowItem + , actOk :: H.ActionItem + , actCancel :: H.ActionItem + , actBrowseRepo :: H.ActionItem + , actBrowseExec :: H.ActionItem + , entRepo :: H.TextEntryItem + , entExec :: H.TextEntryItem + , entAuthor :: H.TextEntryItem + , entEmail :: H.TextEntryItem + , comboBoxVCSType :: H.ComboBoxItem + , checkbtExec :: H.CheckButtonItem + , checkbtAuthor :: H.CheckButtonItem + , lblExec :: H.LabelItem + , btnBrowseExec :: H.ButtonItem + , lblAuthor :: H.LabelItem + , lblEmail :: H.LabelItem + , entPathToTool :: H.TextEntryItem + , actBrowsePathToTool :: H.ActionItem +} + + +{- | Displays a window to setup a repo. Window will be initially filled with content given config + is not Nothing. Given callback will be called on successful completition. +-} +showSetupConfigGUI :: Config + -- ^ maybe a tuple (vcstype,config, mbmergetool), which will be used to fill out the form + -> Callback -- ^ callback, called when dialog is closed + -> IO () +showSetupConfigGUI mbConfig callback = loadAndOpenWindow + (loadSetupRepoGui) + (connectSetupRepoGui callback) + winSetupRepo + (initSetupRepoGui mbConfig) + + +loadSetupRepoGui :: IO SetupRepoGUI +loadSetupRepoGui = loadGuiTemplate $ \builder -> do + winSetupRepo <- H.getWindowFromGlade builder accessorWindowSetupRepo + actOk <- H.getActionFromGlade builder accessorActOk + actCancel <- H.getActionFromGlade builder accessorActCancel + actBrowseRepo <- H.getActionFromGlade builder accessorActBrowseRepo + actBrowseExec <- H.getActionFromGlade builder accessorActBrowseExec + entRepo <- H.getTextEntryFromGlade builder accessorEntRepo + entExec <- H.getTextEntryFromGlade builder accessorEntExec + entAuthor <- H.getTextEntryFromGlade builder accessorEntAuthor + entEmail <- H.getTextEntryFromGlade builder accessorEntEmail + comboBoxVCSType <- H.getComboBoxFromGlade builder accessorEntComboBoxVCSType + checkbtExec <- H.getCheckButtonFromGlade builder accessorCheckbtExec + H.set checkbtExec True + checkbtAuthor <- H.getCheckButtonFromGlade builder accessorCheckbtAuthor + H.set checkbtAuthor True + lblExec <- H.getLabelFromGlade builder accessorLblExec + btnBrowseExec <- H.getButtonFromGlade builder accessorBtnBrowseExec + lblAuthor <- H.getLabelFromGlade builder accessorLblAuthor + lblEmail <- H.getLabelFromGlade builder accessorLblEmail + entPathToTool <- H.getTextEntryFromGlade builder accessorentPathToTool + actBrowsePathToTool <- liftIO $ H.getActionFromGlade builder accessorActBrowsePathToTool + return $ SetupRepoGUI winSetupRepo actOk actCancel actBrowseRepo actBrowseExec entRepo entExec entAuthor entEmail comboBoxVCSType checkbtExec checkbtAuthor lblExec btnBrowseExec lblAuthor lblEmail entPathToTool actBrowsePathToTool + +connectSetupRepoGui :: Callback + -> SetupRepoGUI + -> IO () +connectSetupRepoGui callback gui = do + H.registerClose $ winSetupRepo gui + liftIO $ H.registerCloseAction (actCancel gui) (winSetupRepo gui) + + on (H.getItem (actOk gui)) actionActivated $ + do mbConfig <- createVCSTypAndConfig gui + case mbConfig of + Left errorMsg -> showErrorGUI errorMsg + Right tuple -> do + callback $ Just tuple + H.closeWin $ winSetupRepo gui + + on (H.getItem (actBrowseRepo gui)) actionActivated $ liftIO $ do + mbPath <- showFolderChooserDialog "Choose repository location" (H.getItem $ winSetupRepo gui) FileChooserActionSelectFolder + case mbPath of + Nothing -> return () + Just path -> do + -- discover vcs + availableVCS <- discoverVCS path + H.set (comboBoxVCSType gui) $ map (\vcs -> show vcs) availableVCS + -- update gui + H.set (entRepo gui) path + return () + on (H.getItem (actBrowseExec gui)) actionActivated $ liftIO $ do + mbExec <- showFolderChooserDialog "Choose executable location" (H.getItem $ winSetupRepo gui) FileChooserActionOpen + case mbExec of + Nothing -> return () + Just exec -> do + H.set (entExec gui) exec + H.set (checkbtExec gui) True + return () + + on (H.getItem (checkbtExec gui)) toggled $ do + putStrLn "checkbtnexec toogled" + active <- H.get (checkbtExec gui) + if active then do + widgetShowAll (H.getItem (lblExec gui)) + widgetShowAll (H.getItem (entExec gui)) + widgetShowAll (H.getItem (btnBrowseExec gui)) + else do + widgetHideAll (H.getItem (lblExec gui)) + widgetHideAll (H.getItem (entExec gui)) + widgetHideAll (H.getItem (btnBrowseExec gui)) + + on (H.getItem (checkbtAuthor gui)) toggled $ do + putStrLn "checkbtnauthor toogled" + active <- H.get (checkbtAuthor gui) + if active then do + widgetShowAll (H.getItem (lblAuthor gui)) + widgetShowAll (H.getItem (entAuthor gui)) + widgetShowAll (H.getItem (lblEmail gui)) + widgetShowAll (H.getItem (entEmail gui)) + else do + widgetHideAll (H.getItem (lblAuthor gui)) + widgetHideAll (H.getItem (entAuthor gui)) + widgetHideAll (H.getItem (lblEmail gui)) + widgetHideAll (H.getItem (entEmail gui)) + return () + liftIO $ on (H.getItem (actBrowsePathToTool gui)) actionActivated $ do + mbPath <- showFolderChooserDialog "Select executable" (H.getItem $ winSetupRepo gui) FileChooserActionOpen + case mbPath of + Nothing -> return () + Just path -> do + -- update gui + H.set (entPathToTool gui) path + return () + return () + + where + createVCSTypAndConfig :: SetupRepoGUI -> IO (Either String (Wrapper.VCSType, Wrapper.Config, Maybe MergeTool.MergeTool)) + createVCSTypAndConfig gui = do + path <- H.get (entRepo gui) + + + btExec <- H.get (checkbtExec gui) + exec <- if btExec then + H.get (entExec gui) + else + return Nothing + btAuthor <- H.get (checkbtAuthor gui) + (author,mail) <- if btAuthor then do + a <- H.get (entAuthor gui) + m <- H.get (entEmail gui) + return (a,m) + else + return (Nothing,Nothing) + selectedVCSType <- H.get (comboBoxVCSType gui) + mbPathToTool <- H.get (entPathToTool gui) + let tuple = createVCSTypAndConfig' path author mail exec selectedVCSType mbPathToTool + putStrLn $ "tuple"++show tuple + return tuple + where + createVCSTypAndConfig' Nothing _ _ _ _ _ = Left "You have to set path and type of VCS. Missing path." + createVCSTypAndConfig' _ _ _ _ Nothing _ = Left "You have to set path and type of VCS. Missing vcs type." + createVCSTypAndConfig' _ Nothing (Just _) _ _ _ = Left "If you provide an email you have to provide author as well" + createVCSTypAndConfig' mbPath@(Just path) authorName email executable (Just vcsType) mbPathToTool= Right $ + (read vcsType, + Wrapper.makeConfig mbPath + executable + $ author authorName, + mergeTool mbPathToTool) + where + author (Just name) = (Just (Wrapper.Author name email)) + author Nothing = Nothing + mergeTool (Just path) = Just $ MergeTool.MergeTool path + mergeTool Nothing = Nothing + + +initSetupRepoGui :: Config + -> SetupRepoGUI + -> IO () +initSetupRepoGui mbConfig gui = do + case mbConfig of + Nothing -> return () + Just (vcsType, Wrapper.Config mbPath mbExec mbAuthor _, mbMergeTool) -> do + case mbPath of + Nothing -> return () + Just path -> do + H.set (entRepo gui) $ path + availableVCS <- discoverVCS path + H.set (comboBoxVCSType gui) $ map (\vcs -> show vcs) availableVCS + if isInfixOf [vcsType] availableVCS + then do + --get position (hopefully always index in liststore = index in list) + let index = elemRIndex vcsType availableVCS + + --set active + comboBoxSetActive (H.getItem (comboBoxVCSType gui)) $ fromMaybe (-1) index + else do + return () + case mbExec of + Nothing -> do + H.set (checkbtExec gui) False + return () + Just exec -> do + H.set (checkbtExec gui) True + H.set (entExec gui) $ exec + + case mbAuthor of + Nothing -> do + H.set (checkbtAuthor gui) False + return () + Just (Wrapper.Author author email) -> do + H.set (checkbtAuthor gui) True + H.set (entAuthor gui) author + H.set (entEmail gui) $ fromMaybe "" email + case mbMergeTool of + Nothing -> return() + Just mergeTool -> H.set (entPathToTool gui) (MergeTool.fullPath mergeTool) + + return () + +discoverVCS :: FilePath -- ^ path to root + -> IO [Wrapper.VCSType] -- ^ vcs discovered +discoverVCS path = do + exists <- doesDirectoryExist path + putStrLn $ "Path "++ show exists ++ " Starting discovery." + case exists of + True -> do + content <- getDirectoryContents path + let vcsFiles = map vcsMapping $ filter vcsFilter content + putStrLn $ "Available vcs: "++ show vcsFiles + return vcsFiles + False -> do + return [] + where + vcsFilter :: FilePath -> Bool + vcsFilter path = case path of + ".git" -> True + ".svn" -> True + ".hg" -> True + _ -> False + vcsMapping :: FilePath -> Wrapper.VCSType + vcsMapping path = case path of + ".git" -> Wrapper.GIT + ".svn" -> Wrapper.SVN + ".hg" -> Wrapper.Mercurial + _ -> Wrapper.SVN --TODO throw error on this, improve this code + +-- | shows a dialog to choose a folder, returns Just FilePath to folder if succesfull, Nothing if cancelled +showFolderChooserDialog :: String -- ^ title of the window + -> Window -- ^ parent window + -> FileChooserAction + -> IO (Maybe FilePath) +showFolderChooserDialog title parent fcAction = do + dialog <- fileChooserDialogNew (Just title) (Just parent) fcAction [("Cancel", ResponseCancel), ("Select", ResponseAccept)] + response <- dialogRun dialog + case response of + ResponseCancel -> widgetDestroy dialog >> return Nothing + ResponseDeleteEvent -> widgetDestroy dialog >> return Nothing + ResponseAccept -> do + f <- fileChooserGetFilename dialog + widgetDestroy dialog + return f + + + +loadAndOpenWindow :: IO SetupRepoGUI -- ^ load gui fn + -> (SetupRepoGUI -> IO ()) -- ^ connect gui fn + -> (SetupRepoGUI -> H.WindowItem) -- ^ get WindowItem from gui + -> (SetupRepoGUI -> IO ()) -- ^ init gui + -> IO () +loadAndOpenWindow loadGui connectGui getWindow initRepo = do + gui <- loadGui + connectGui gui + widgetShowAll $ H.getItem (getWindow gui) + initRepo gui + return () + + +loadGuiTemplate :: (Builder -> IO a) -> IO a +loadGuiTemplate builderFn = do + gladepath <- getGladepath + builder <- H.openGladeFile gladepath + builderFn builder diff --git a/src/VCSGui/Git.hs b/src/VCSGui/Git.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Git.hs @@ -0,0 +1,30 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Git +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Exports all modules needed to build the Git GUI component. +-- +----------------------------------------------------------------------------- + +module VCSGui.Git ( + module VCSGui.Git.Commit + , module VCSGui.Git.Log + , module VCSGui.Git.Helpers + , module VCSGui.Common + , module VCSGui.Git.Pull +) where + +import VCSGui.Git.Commit +import VCSGui.Git.Log +import VCSGui.Common +import VCSGui.Git.Helpers +import VCSGui.Git.Pull + + + diff --git a/src/VCSGui/Git/Commit.hs b/src/VCSGui/Git/Commit.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Git/Commit.hs @@ -0,0 +1,76 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Git.Commit +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Every function related to commiting changes to the Git repository is found in this module. +-- +----------------------------------------------------------------------------- + +module VCSGui.Git.Commit ( + showCommitGUI +) where + +import Control.Monad.Trans(liftIO) +import Control.Monad.Reader(ask) + +import Graphics.UI.Gtk + +import VCSGui.Common.GtkHelper +import qualified VCSGui.Common.Commit as Commit + +import qualified VCSWrapper.Git as Git +import qualified VCSWrapper.Common as Wrapper + + +doCommit :: String -> [FilePath] -> [Commit.Option] -> Wrapper.Ctx () +doCommit commitMsg files _ = do + Git.add files + (Wrapper.Config _ _ mbAuthor _) <- ask + case mbAuthor of + Nothing -> Git.commit files Nothing commitMsg [] + Just (Wrapper.Author author mbEmail) -> do + case mbEmail of + Nothing -> Git.commit files (Just (author, "noEmailSet@noEmailSet")) commitMsg [] + Just m -> Git.commit files (Just (author, m)) commitMsg [] + +{- | Calls 'Commit.showCommitGUI' with a 'Graphics.UI.Gtk.ListStore' and 'OkCallBack' setup for Git. + This will display a window to enter a commit message and select the files to be commited by this commit. +-} +showCommitGUI :: Git.Ctx () +showCommitGUI = do + Commit.showCommitGUI setupListStore doCommit + +setupListStore :: TreeView -> Wrapper.Ctx (ListStore Commit.SCFile) +setupListStore view = do + repoStatus <- Git.status + --GITSCFile Bool FilePath String + let selectedF = [Commit.GITSCFile True fp (show mod) | (Wrapper.GITStatus fp mod) <- repoStatus, mod == Wrapper.Modified || mod == Wrapper.Added] + notSelectedF = [Commit.GITSCFile False fp (show mod) | (Wrapper.GITStatus fp mod) <- repoStatus, mod /= Wrapper.Modified && mod /= Wrapper.Added] + + liftIO $ do + store <- listStoreNew (selectedF ++ notSelectedF) + treeViewSetModel view store + let item = (store, view) + + toggleRenderer <- cellRendererToggleNew + addColumnToTreeView' item toggleRenderer "Commit" (\(Commit.GITSCFile s _ _)-> [cellToggleActive := s]) + addTextColumnToTreeView' item "File" (\(Commit.GITSCFile _ p _) -> [cellText := p]) + addTextColumnToTreeView' item "File status" (\(Commit.GITSCFile _ _ m) -> [cellText := m]) + + -- register toggle renderer + on toggleRenderer cellToggled $ \filepath -> do + putStrLn ("toggle called: " ++ filepath) + + Just treeIter <- treeModelGetIterFromString store filepath + value <- listStoreGetValue store $ listStoreIterToIndex treeIter + let newValue = (\(Commit.GITSCFile b fp m) -> Commit.GITSCFile (not b) fp m) value + listStoreSetValue store (listStoreIterToIndex treeIter) newValue + return () + return store + diff --git a/src/VCSGui/Git/Helpers.hs b/src/VCSGui/Git/Helpers.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Git/Helpers.hs @@ -0,0 +1,35 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Git.Helpers +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Misc helper functions. +-- +----------------------------------------------------------------------------- + +module VCSGui.Git.Helpers ( + askPassWrapper +) where + +import VCSWrapper.Git +import Control.Monad.Reader.Class (asks, MonadReader(..)) +import System.Environment (getEnvironment) +import Control.Monad.Reader (liftIO) + + +{- | Adds a wrapper to the 'Ctx' so git can ask for a password using a GUI window. + This is acomplished by setting the GIT_ASKPASS environment variable. + This is only tested on linux and may not work on MS Windows. +-} +askPassWrapper :: Ctx () -> Ctx () +askPassWrapper fn = do + cfgEnv <- asks configEnvironment + inheritEnv <- liftIO $ getEnvironment + -- TODO better solution for DISPLAY? TODO will this work on windows? + local (\cfg -> cfg {configEnvironment = ("GIT_ASKPASS", "vcsgui-askpass"):("DISPLAY", ":0.0"):inheritEnv ++ cfgEnv}) fn + diff --git a/src/VCSGui/Git/Log.hs b/src/VCSGui/Git/Log.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Git/Log.hs @@ -0,0 +1,83 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Git.Log +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Every function related to displaying the history of a Git repository is found in this module. +-- +----------------------------------------------------------------------------- + +module VCSGui.Git.Log ( + showLogGUI +) where + +import qualified Graphics.UI.Gtk as Gtk +import qualified VCSGui.Common.Log as Common +import qualified VCSWrapper.Git as Git +import Control.Monad.Reader (liftIO) +import Data.Maybe (fromMaybe) +import VCSGui.Common.Helpers (emptyListToNothing) + + +{- | Calls 'Common.showLogGUI' using Git. This will display all log entries. The branch to be displayed can be selected. + Any commit can be checked out, creating a new branch if the commit is not already the HEAD of any branch. + -} +showLogGUI :: Git.Ctx () +showLogGUI = do + log <- Git.simpleLog Nothing + branches <- Git.localBranches + Common.showLogGUI log [] (Just (branches, \branch -> Git.simpleLog (Just branch))) checkout False + where + checkout log Nothing = Git.checkout (Just $ Git.commitID log) Nothing + checkout log (Just selBranch) = do + revBranch <- Git.revparse selBranch + case ((Git.commitID log) == revBranch) of + True -> do + liftIO $ putStrLn "checking out selected Branch" + Git.checkout (Just selBranch) Nothing + False -> do + liftIO $ putStrLn $ "checking out Commit " ++ (Git.commitID log) ++ ", asking for new branchname" + mbBranchname <- liftIO $ askForNewBranchname + Git.checkout (Just $ Git.commitID log) (mbBranchname) + + askForNewBranchname :: IO (Maybe String) + askForNewBranchname = do + dialog <- Gtk.dialogNew + Gtk.dialogAddButton dialog "gtk-ok" Gtk.ResponseOk + upper <- Gtk.dialogGetUpper dialog + + inputBranch <- Gtk.entryNew + lblBranch <- Gtk.labelNew $ Just "Enter a new branchname (empty for anonym branch):" + box <- Gtk.hBoxNew False 2 + Gtk.containerAdd upper box + Gtk.containerAdd box lblBranch + Gtk.containerAdd box inputBranch + + Gtk.widgetShowAll dialog + _ <- Gtk.dialogRun dialog + branchname <- Gtk.entryGetText inputBranch + Gtk.widgetDestroy dialog + return $ emptyListToNothing branchname + + + + + + + + + + + + + + + + + + diff --git a/src/VCSGui/Git/Pull.hs b/src/VCSGui/Git/Pull.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Git/Pull.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Git.Pull +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Every function related to pulling changes from another Git repository is found in this module. +-- +----------------------------------------------------------------------------- + +module VCSGui.Git.Pull ( + pull +) where + +import Control.Monad.Trans(liftIO) + +import qualified VCSWrapper.Git as Git +import qualified VCSWrapper.Common as Wrapper + +import VCSGui.Common.Error + + +-- | Call 'Git.pull'. If the pull fails or a merge conflict is detected an error message is shown. +pull :: Git.Ctx () +pull = do + o <- Git.pull + case o of + Right () -> return () + Left msg -> liftIO $ showErrorGUI $ "MERGE CONFLICT " ++ msg diff --git a/src/VCSGui/Mercurial.hs b/src/VCSGui/Mercurial.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Mercurial.hs @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Mercurial +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL Nothing +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module VCSGui.Mercurial ( + module VCSGui.Mercurial.Commit + , module VCSGui.Mercurial.Log + , module VCSGui.Common +) where + +import VCSGui.Mercurial.Commit +import VCSGui.Mercurial.Log +import VCSGui.Common + + + diff --git a/src/VCSGui/Mercurial/Commit.hs b/src/VCSGui/Mercurial/Commit.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Mercurial/Commit.hs @@ -0,0 +1,70 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Mercurial.Commit +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL Nothing +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module VCSGui.Mercurial.Commit ( + showCommitGUI +) where + +import Control.Monad.Trans(liftIO) +import Control.Monad.Reader(ask) + +import Graphics.UI.Gtk + +import VCSGui.Common.GtkHelper +import qualified VCSGui.Common.Commit as Commit + +import qualified VCSWrapper.Mercurial as Mercurial +import qualified VCSWrapper.Common as Wrapper + +doCommit :: String -> [FilePath] -> [Commit.Option] -> Wrapper.Ctx () +doCommit commitMsg files _ = do + Mercurial.addremove files + Mercurial.commit files commitMsg [] + +{- | + Calls 'Commit.showCommitGUI' with a 'Graphics.UI.Gtk.ListStore' and 'OkCallBack' setup for Mercurial. + This will display a window to enter a commit message and select the files to be commited by this commit. +-} +showCommitGUI :: Mercurial.Ctx () +showCommitGUI = do + Commit.showCommitGUI setupListStore doCommit + +--TODO this is copy&pasted from git implementation refactor it and use abstract version +setupListStore :: TreeView -> Wrapper.Ctx (ListStore Commit.SCFile) +setupListStore view = do + repoStatus <- Mercurial.status + --GITSCFile Bool FilePath String + let selectedF = [Commit.GITSCFile True fp (show mod) | (Wrapper.GITStatus fp mod) <- repoStatus, mod == Wrapper.Modified || mod == Wrapper.Added] + notSelectedF = [Commit.GITSCFile False fp (show mod) | (Wrapper.GITStatus fp mod) <- repoStatus, mod /= Wrapper.Modified && mod /= Wrapper.Added] + + liftIO $ do + store <- listStoreNew (selectedF ++ notSelectedF) + treeViewSetModel view store + let item = (store, view) + + toggleRenderer <- cellRendererToggleNew + addColumnToTreeView' item toggleRenderer "Commit" (\(Commit.GITSCFile s _ _)-> [cellToggleActive := s]) + addTextColumnToTreeView' item "File" (\(Commit.GITSCFile _ p _) -> [cellText := p]) + addTextColumnToTreeView' item "File status" (\(Commit.GITSCFile _ _ m) -> [cellText := m]) + + -- register toggle renderer + on toggleRenderer cellToggled $ \filepath -> do + putStrLn ("toggle called: " ++ filepath) + + Just treeIter <- treeModelGetIterFromString store filepath + value <- listStoreGetValue store $ listStoreIterToIndex treeIter + let newValue = (\(Commit.GITSCFile b fp m) -> Commit.GITSCFile (not b) fp m) value + listStoreSetValue store (listStoreIterToIndex treeIter) newValue + return () + return store diff --git a/src/VCSGui/Mercurial/Log.hs b/src/VCSGui/Mercurial/Log.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Mercurial/Log.hs @@ -0,0 +1,34 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Mercurial.Log +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL Nothing +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module VCSGui.Mercurial.Log ( + showLogGUI +) where + +import qualified Graphics.UI.Gtk as Gtk +import qualified VCSGui.Common.Log as Common +import qualified VCSWrapper.Mercurial as Mercurial +import Control.Monad.Reader (liftIO) +import Data.Maybe (fromMaybe) + +{- | Calls 'Common.showLogGUI' using hg. This will display all log entries. The branch to be displayed can be selected. + Any commit can be checked out, creating a new branch if the commit is not already the HEAD of any branch. + -} +showLogGUI :: Mercurial.Ctx () +showLogGUI = do + log <- Mercurial.simpleLog Nothing + liftIO $ putStrLn $ "Received log"++show log + Common.showLogGUI log [] Nothing checkout True + where + checkout logEntry Nothing = Mercurial.update (Just $ Mercurial.commitID logEntry) diff --git a/src/VCSGui/Svn.hs b/src/VCSGui/Svn.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Svn.hs @@ -0,0 +1,30 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Svn +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Exports all available SVN GUIs such as @checkout@, @log@ and others. +-- +----------------------------------------------------------------------------- + +module VCSGui.Svn ( + module VCSGui.Svn.Checkout + , module VCSGui.Svn.Commit + , module VCSGui.Svn.Log + , module VCSGui.Common + , module VCSGui.Svn.AskPassword + , module VCSGui.Svn.Update +) where + +import VCSGui.Svn.AskPassword +import VCSGui.Svn.Checkout +import VCSGui.Svn.Commit +import VCSGui.Svn.Log +import VCSGui.Svn.Update +import VCSGui.Common + diff --git a/src/VCSGui/Svn/AskPassword.hs b/src/VCSGui/Svn/AskPassword.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Svn/AskPassword.hs @@ -0,0 +1,132 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Svn.AskPassword +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- TODO this should be moved into Common Package +-- | Provides a GUI asking a user for a password. +-- +----------------------------------------------------------------------------- + +module VCSGui.Svn.AskPassword ( + showAskpassGUI + ,Handler +) where + +import qualified VCSGui.Common.GtkHelper as H +import qualified VCSGui.Common as VCSGUI + +import qualified VCSWrapper.Common as Wrapper + +import Graphics.UI.Gtk + +import Data.Maybe (fromMaybe) +import Control.Monad.Trans(liftIO) +import Paths_vcsgui(getDataFileName) +import Control.Monad.Reader(ask) +-- +-- glade path and object accessors +-- +getGladepath = getDataFileName "data/guiSvnAskpass.glade" +accessorWindow = "windowAskpass" +accessorActOk = "actOk" +accessorActCancel = "actCancel" +accessorEntryPw = "entryPw" +accessorCheckbtUsePw = "checkbtUsePw" +accessorCheckbtSaveForSession = "checkbtSaveForSession" +accessorboxUsePwd = "boxUsePwd" + +{- | + 'Handler' is a function used as an argument to the 'showAskpassGUI'. It represents a VCS + command running in a 'Wrapper.Ctx' expecting password data which can be the followingAxis + * Nothing, if GUI is closed or cancel button is pressed + * Just (savePasswordSettingForSession, Maybe password) + where savePasswordSettingForSession indicates if password-settings should be saved for current + session. Maybe password is either: + * Nothing, no password given + * Just password, password has been provided +-} +type Handler = ((Maybe (Bool, Maybe String)) + -> Wrapper.Ctx()) + +data AskpassGUI = AskpassGUI { + windowAskpass :: H.WindowItem + ,actOk :: H.ActionItem + ,actCancel :: H.ActionItem + ,entryPw :: H.TextEntryItem + ,checkbtUsePw :: H.CheckButtonItem + ,checkbtSaveForSession :: H.CheckButtonItem + ,boxUsePwd :: VBox +} + +-- | Shows a GUI asking the user for a password. 'Handler' will be called with result. +showAskpassGUI :: Handler -- ^ 'Handler' to be called when GUI is closed passing the result. + -> Wrapper.Ctx () +showAskpassGUI handler = do + config <- ask + liftIO $ do + gui <- loadAskpassGUI + + -- connect actions + registerClose (windowAskpass gui) handler config + registerCloseAction (actCancel gui) (windowAskpass gui) handler config + on (H.getItem (actOk gui)) actionActivated $ do + putStrLn "ok clicked" + usePw <- H.get $ checkbtUsePw gui + pw <- H.get (entryPw gui) + saveForSession <- H.get $ checkbtSaveForSession gui + + let args = if usePw then Just (saveForSession, Just $ fromMaybe "" pw) + else Just (saveForSession, Nothing) + VCSGUI.defaultVCSExceptionHandler $ Wrapper.runVcs config $ handler args + H.closeWin (windowAskpass gui) + on (H.getItem (checkbtUsePw gui)) toggled $ do + active <- get (H.getItem (checkbtUsePw gui)) toggleButtonActive + if active then + widgetShowAll (boxUsePwd gui) + else + widgetHideAll (boxUsePwd gui) + -- present window + widgetShowAll $ H.getItem $ windowAskpass gui + return () + +registerClose :: H.WindowItem + -> Handler + -> Wrapper.Config + -> IO() +registerClose win handler config = on (H.getItem win) deleteEvent (liftIO (close win handler config) >> return False) >> return () + +registerCloseAction :: H.ActionItem + -> H.WindowItem + -> Handler + -> Wrapper.Config + -> IO() +registerCloseAction act win handler config = on (H.getItem act) actionActivated (liftIO (close win handler config)) >> return () + +close :: H.WindowItem + -> Handler + -> Wrapper.Config + -> IO() +close win handler config = do + liftIO $ H.closeWin win + VCSGUI.defaultVCSExceptionHandler $ Wrapper.runVcs config $ handler Nothing + +loadAskpassGUI :: IO AskpassGUI +loadAskpassGUI = do + gladepath <- getGladepath + builder <- H.openGladeFile gladepath + + windowAskpass <- H.getWindowFromGlade builder accessorWindow + actOk <- H.getActionFromGlade builder accessorActOk + actCancel <- H.getActionFromGlade builder accessorActCancel + entryPw <- H.getTextEntryFromGlade builder accessorEntryPw + checkbtUsePw <- H.getCheckButtonFromGlade builder accessorCheckbtUsePw + set (H.getItem checkbtUsePw) [toggleButtonActive := True] + checkbtSaveForSession <- H.getCheckButtonFromGlade builder accessorCheckbtSaveForSession + set (H.getItem checkbtSaveForSession) [toggleButtonActive := True] + boxUsePw <- builderGetObject builder castToVBox accessorboxUsePwd + return $ AskpassGUI windowAskpass actOk actCancel entryPw checkbtUsePw checkbtSaveForSession boxUsePw diff --git a/src/VCSGui/Svn/Checkout.hs b/src/VCSGui/Svn/Checkout.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Svn/Checkout.hs @@ -0,0 +1,88 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Svn.Checkout +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Provides a GUI for checking out a working copy of a SVN repository. +-- +----------------------------------------------------------------------------- + +module VCSGui.Svn.Checkout ( + showCheckoutGUI +) where + +import Graphics.UI.Gtk +import Control.Monad.Trans(liftIO) +import Control.Monad +import Control.Monad.Reader +import qualified VCSWrapper.Svn as Svn +import qualified VCSGui.Common.GtkHelper as H +import Paths_vcsgui(getDataFileName) +import Maybe +-- +-- glade path and object accessors +-- + +getGladepath = getDataFileName "data/guiSvnCheckout.glade" +accessorWindowCheckout = "windowCheckout" +accessorActCheckout = "actCheckout" +accessorActCancel = "actCancel" +accessorActTxtViewUrl = "txtViewUrl" +accessorActTxtViewRevision = "txtViewRevision" +accessorActTxtViewPath = "txtViewPath" + +data CheckoutGUI = CheckoutGUI { + windowCheckout :: H.WindowItem + ,actCheckout :: H.ActionItem + ,actCancel :: H.ActionItem + ,txtViewUrl :: H.TextViewItem + ,txtViewRevision :: H.TextViewItem + ,txtViewPath :: H.TextViewItem + } + +-- | Shows a GUI asking user for data to checkout a working copy of a SVN repository. +showCheckoutGUI :: Svn.Ctx() +showCheckoutGUI = do + config <- ask + liftIO $ do + putStrLn "Starting gui ..." + gui <- loadCheckoutGUI + + -- connect actions + H.registerClose $ windowCheckout gui + H.registerCloseAction (actCancel gui) (windowCheckout gui) + liftIO $ on (H.getItem (actCheckout gui)) actionActivated $ do + url <- H.get (txtViewUrl gui) + realRevision <- H.get (txtViewRevision gui) + realFilePath <- H.get (txtViewPath gui) + let mbPwd = Nothing + Svn.runVcs config $ Svn.checkout [(fromMaybe "" url, realRevision)] realFilePath mbPwd [] -- TODO pw handler + H.closeWin $ windowCheckout gui + + + liftIO $ widgetShowAll $ H.getItem $ windowCheckout gui + + liftIO $ putStrLn "Finished" + return () + + +loadCheckoutGUI :: IO CheckoutGUI +loadCheckoutGUI = do + putStrLn $ "Creating builder from gladefile" + gladepath <- liftIO getGladepath + builder <- liftIO $ H.openGladeFile gladepath + + putStrLn $ "Creating gtk widgets from builder" + win <- liftIO $ H.getWindowFromGlade builder accessorWindowCheckout + actCheckout <- liftIO $ H.getActionFromGlade builder accessorActCheckout + actCancel <- liftIO $ H.getActionFromGlade builder accessorActCancel + txtViewUrl <- liftIO $ H.getTextViewFromGlade builder accessorActTxtViewUrl + txtViewRevision <- liftIO $ H.getTextViewFromGlade builder accessorActTxtViewRevision + txtViewPath <- liftIO $ H.getTextViewFromGlade builder accessorActTxtViewPath + return $ CheckoutGUI win actCheckout actCancel txtViewUrl txtViewRevision txtViewPath + diff --git a/src/VCSGui/Svn/Commit.hs b/src/VCSGui/Svn/Commit.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Svn/Commit.hs @@ -0,0 +1,135 @@ +----------------------------------------------------------------------------- +-- +-- Module : Main +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Provides a GUI to commit to a SVN working copy. +-- +----------------------------------------------------------------------------- +module VCSGui.Svn.Commit ( + showCommitGUI +) where + +import qualified VCSGui.Common.Commit as C +import qualified VCSGui.Common.GtkHelper as H +import qualified VCSGui.Common.FilesInConflict as FiC +import qualified VCSGui.Common.MergeTool as M +import qualified VCSGui.Svn.Helper as SvnH + +import VCSGui.Svn.AskPassword +import VCSGui.Common.ExceptionHandler + +import qualified VCSWrapper.Svn as Svn + +import Graphics.UI.Gtk +import Control.Monad.Trans(liftIO) + +{- | + Shows a GUI showing status of subversion and possibilites to commit/cancel. +-} +showCommitGUI :: Either M.MergeTool M.MergeToolSetter -- ^ 'MergeTool' is used for any possible conflicts. If not present user will be asked to provide 'MergeTool' on conflicts. 'MergeToolSetter' will be called for response. + -> Either Handler (Maybe String) -- ^ Either 'Handler' for password request or password (nothing for no password) + -> Svn.Ctx() +showCommitGUI eMergeToolSetter eitherHandlerOrPw = do + conflictingFiles <- SvnH.getConflictingFiles + case conflictingFiles of + [] -> commonCommit + _ -> FiC.showFilesInConflictGUI + Nothing + (conflictingFiles) + (Svn.getFilesInConflict) + (\fileToResolve -> Svn.resolved [fileToResolve] Nothing []) + eMergeToolSetter + $ commonCommit + where + commonCommit = C.showCommitGUI setUpTreeView (okCallback eitherHandlerOrPw) + + +okCallback :: Either Handler (Maybe String) -- ^ either callback for password request or password (nothing for no password) + -> String -- ^ commit message + -> [FilePath] -- ^ selected files + -> [C.Option] -- ^ TODO options + -> Svn.Ctx () +okCallback eitherHandlerOrPw msg filesToCommit _ = do + case eitherHandlerOrPw of + Left handler -> do + showAskpassGUI (ownHandler handler) + return () + Right pw -> doCommit msg filesToCommit pw + + where + doCommit msg filesToCommit mbPw = do + Svn.add filesToCommit mbPw [] + Svn.commit filesToCommit msg mbPw [] + return() + ownHandler :: Handler + -> Handler + ownHandler handler = \result -> do + case result of + Nothing -> handler result + Just (_,mbPw) -> do + doCommit msg filesToCommit mbPw + handler result + + + +setUpTreeView :: TreeView -> Svn.Ctx (ListStore C.SCFile) +setUpTreeView listView = do + -- get status + repoStatus <- Svn.status + + --check files for conflicts + + liftIO $ do + -- create model + listStore <- listStoreNew [ + (C.SVNSCFile (ctxSelect (Svn.modification status)) + (Svn.filePath status) + (show (Svn.modification status)) + (Svn.isLocked status)) + | status <- repoStatus] + treeViewSetModel listView listStore + + let treeViewItem = (listStore, listView) + + renderer <- cellRendererToggleNew + H.addColumnToTreeView' treeViewItem + renderer + "" + $ \scf -> [cellToggleActive := C.selected scf] + + -- connect select action + on renderer cellToggled $ \columnId -> do + Just treeIter <- treeModelGetIterFromString listStore columnId + value <- listStoreGetValue listStore $ listStoreIterToIndex treeIter + let newValue = (\(C.SVNSCFile bool fp s l) -> C.SVNSCFile (not bool) fp s l) + value + listStoreSetValue listStore (listStoreIterToIndex treeIter) newValue + return () + + renderer <- cellRendererTextNew + H.addColumnToTreeView' treeViewItem + renderer + "Files to commit" + $ \scf -> [cellText := C.filePath scf] + + renderer <- cellRendererTextNew + H.addColumnToTreeView' treeViewItem + renderer + "Status" + $ \scf -> [cellText := C.status scf] + + renderer <- cellRendererToggleNew + H.addColumnToTreeView' treeViewItem + renderer + "Locked" + $ \scf -> [cellToggleActive := C.isLocked scf] + return listStore + where + ctxSelect status = status == Svn.Added || status == Svn.Deleted || status==Svn.Modified || + status == Svn.Replaced diff --git a/src/VCSGui/Svn/Helper.hs b/src/VCSGui/Svn/Helper.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Svn/Helper.hs @@ -0,0 +1,24 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Svn.Helper +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module VCSGui.Svn.Helper ( + getConflictingFiles +) where + +import qualified VCSWrapper.Svn as Svn + +getConflictingFiles :: Svn.Ctx [FilePath] +getConflictingFiles = do + status <- Svn.status + return [ Svn.filePath s | s <- status, (Svn.modification s) == Svn.Conflicting]; diff --git a/src/VCSGui/Svn/Log.hs b/src/VCSGui/Svn/Log.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Svn/Log.hs @@ -0,0 +1,58 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Svn.Log +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Provides a GUI to show log for current working copy. +-- +----------------------------------------------------------------------------- + +module VCSGui.Svn.Log ( + showLogGUI +) where + +import qualified VCSGui.Common.Log as C +import VCSGui.Svn.AskPassword + +import qualified VCSWrapper.Svn as Svn +import qualified VCSWrapper.Common as WC + +-- | Shows a GUI showing log for current working copy. +showLogGUI :: Either Handler (Maybe String) -- ^ Either 'Handler' for password request or password (nothing for no password) + -> Svn.Ctx () +showLogGUI eitherHandlerOrPw = do + logEntries <- Svn.simpleLog + C.showLogGUI logEntries [] Nothing (okCallback eitherHandlerOrPw) False + +okCallback :: Either Handler (Maybe String) -- ^ either callback for password request or password (nothing for no password) + -> WC.LogEntry -- ^ chosen logentry + -> Maybe String -- ^ chosen branch name + -> WC.Ctx() +okCallback eitherHandlerOrPw logEntry _ = do + case eitherHandlerOrPw of + Left handler -> do + showAskpassGUI (ownHandler handler) + return () + Right pw -> doRevert logEntry pw + + + where + ownHandler :: Handler + -> Handler + ownHandler handler = \result -> do + case result of + Nothing -> handler result + Just (_,mbPw) -> do + doRevert logEntry mbPw + handler result + doRevert logEntry mbPw = do + Svn.mergeHeadToRevision (revision logEntry) mbPw [] + return() + revision logEntry = read $ Svn.commitID logEntry :: Integer + + diff --git a/src/VCSGui/Svn/Update.hs b/src/VCSGui/Svn/Update.hs new file mode 100644 --- /dev/null +++ b/src/VCSGui/Svn/Update.hs @@ -0,0 +1,58 @@ +----------------------------------------------------------------------------- +-- +-- Module : VCSGui.Svn.Update +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- | Provides facilities to update a SVN working copy. +-- +----------------------------------------------------------------------------- + +module VCSGui.Svn.Update ( + showUpdateGUI +) where + +import qualified VCSGui.Svn.AskPassword as AskPassword +import qualified VCSGui.Svn.Helper as SvnH +import qualified VCSGui.Common.Error as Error +import qualified VCSGui.Common.MergeTool as M +import qualified VCSGui.Common.FilesInConflict as FiC + +import qualified VCSWrapper.Svn as Svn +import qualified VCSWrapper.Common as Wrapper + +import Control.Monad.Trans(liftIO) + +-- | Initiates an update for current SVN working copy. +showUpdateGUI :: Either M.MergeTool M.MergeToolSetter -- ^ 'MergeTool' is used for any possible conflicts. If not present user will be asked to provide 'MergeTool' on conflicts after updating. 'MergeToolSetter' will be called for response. + -> Either AskPassword.Handler (Maybe String) -- ^ If a password is provided it will be used, if not a GUI will be shown to ask for password and given @Handler@ will be called. + -> Wrapper.Ctx() +showUpdateGUI eMergeToolSetter (Left handler) = do + AskPassword.showAskpassGUI $ ownHandler eMergeToolSetter handler + return () +showUpdateGUI eMergeToolSetter (Right mbPwd) = do + Svn.update mbPwd [] + conflictingFiles <- SvnH.getConflictingFiles + case conflictingFiles of + [] -> return () + _ -> FiC.showFilesInConflictGUI + Nothing + (conflictingFiles) + (Svn.getFilesInConflict) + (\fileToResolve -> Svn.resolved [fileToResolve] Nothing []) + eMergeToolSetter + $ (return ()) + +ownHandler :: Either M.MergeTool M.MergeToolSetter -- ^ either a mergetool or a setter for it + -> (AskPassword.Handler + -> AskPassword.Handler) +ownHandler eMergeToolSetter handler = \result -> do + case result of + Nothing -> handler result + Just (_,mbPw) -> do + showUpdateGUI eMergeToolSetter $ Right mbPw + handler result diff --git a/src/exe/askpass/Main.hs b/src/exe/askpass/Main.hs new file mode 100644 --- /dev/null +++ b/src/exe/askpass/Main.hs @@ -0,0 +1,76 @@ +----------------------------------------------------------------------------- +-- +-- Module : Main +-- Copyright : 2011 Stephan Fortelny, Harald Jagenteufel +-- License : GPL +-- +-- Maintainer : stephanfortelny at gmail.com, h.jagenteufel at gmail.com +-- Stability : +-- Portability : +-- +-- TODO since this window has to print the entered password to stdout, nothing else must be printed to stdout. can we fix this? (logging) +-- | A simple window to enter a password. Prints the password to stdout (as required for GIT_ASKPASS). +-- +----------------------------------------------------------------------------- + +module Main ( + main +) where + +import Graphics.UI.Gtk +import qualified VCSGui.Common.GtkHelper as H +import Data.Maybe (fromMaybe) + +import Paths_vcsgui(getDataFileName) +-- +-- glade path and object accessors +-- +getGladepath = getDataFileName "data/guiCommonAskpass.glade" +accessorWindow = "windowAskpass" +accessorActOk = "actOk" +accessorActCancel = "actCancel" +accessorEntryPw = "entryPw" + + +data AskpassGUI = AskpassGUI { + window :: H.WindowItem + ,actOk :: H.ActionItem + ,actCancel :: H.ActionItem + ,entryPw :: H.TextEntryItem +} + + +main :: IO () +main = do + initGUI + showAskpassGUI + mainGUI + + +showAskpassGUI :: IO () +showAskpassGUI = do + gui <- loadCommitGUI + + -- connect actions + H.registerQuit $ window gui + H.registerQuitAction $ actCancel gui + on (H.getItem (actOk gui)) actionActivated $ do + pw <- H.get (entryPw gui) + putStr $ fromMaybe "" pw + mainQuit + -- present window + widgetShowAll $ H.getItem $ window gui + return () + + +loadCommitGUI :: IO AskpassGUI +loadCommitGUI = do + gladepath <- getGladepath + builder <- H.openGladeFile gladepath + + win <- H.getWindowFromGlade builder accessorWindow + actOk <- H.getActionFromGlade builder accessorActOk + actCancel <- H.getActionFromGlade builder accessorActCancel + entryPw <- H.getTextEntryFromGlade builder accessorEntryPw + return $ AskpassGUI win actOk actCancel entryPw + diff --git a/vcsgui.cabal b/vcsgui.cabal new file mode 100644 --- /dev/null +++ b/vcsgui.cabal @@ -0,0 +1,98 @@ +name: vcsgui +version: 0.0.1 +cabal-version: >= 1.8 +build-type: Simple +license: GPL +license-file: LICENSE +copyright: 2011 Stephan Fortelny, Harald Jagenteufel +maintainer: stephanfortelny at gmail.com, h.jagenteufel at gmail.com +homepage: https://github.com/forste/haskellVCSGUI +bug-reports: https://github.com/forste/haskellVCSGUI/issues +synopsis: GUI library for source code management systems +description: + Provides library functions to expose some commonly needed scm tasks to the user. + Uses GTK+ and GTKBuilder to organize and display windows. + Uses vcswrapper to acces the scm functions. + Currently git and SVN are supported. +category: Development +author: Stephan Fortelny, Harald Jagenteufel +tested-with: GHC == 7.0 +data-files: LICENSE + data/guiCommonCommit.glade + data/guiCommonLog.glade + data/guiCommonSetupRepo.glade + data/guiSvnCheckout.glade + data/guiCommonAskpass.glade + data/guiSvnAskpass.glade + data/guiCommonFilesInConflict.glade + data/guiCommonMergeTool.glade + data/guiCommonConflictsResolved.glade +data-dir: "" +library + build-depends: MissingH >=1.1.0.3 && <1.2, + filepath >=1.2.0.0 && < 1.3, + base >=4.0.0.0 && <4.4, + directory >=1.1.0.0 && <1.2, + haskell98 >=1.1.0.1 && <1.2, + mtl >=2.0.1.0 && <2.1, + vcswrapper ==0.0.1, + process >=1.0.1.5 && <1.1, + gtk >=0.12.0 && <0.13 + exposed-modules: VCSGui.Common VCSGui.Git VCSGui.Svn VCSGui.Mercurial + exposed: True + buildable: True + hs-source-dirs: src + other-modules: VCSGui.Svn.Helper VCSGui.Common.Process + VCSGui.Common.ConflictsResolved VCSGui.Common.MergeTool + VCSGui.Common.FilesInConflict VCSGui.Git.Pull VCSGui.Svn.Update + VCSGui.Svn.AskPassword VCSGui VCSGui.Svn.Log VCSGui.Svn.Checkout + VCSGui.Svn.Commit VCSGui.Git.Log VCSGui.Git.Helpers + VCSGui.Git.Commit VCSGui.Common.Log + VCSGui.Common.GtkHelper VCSGui.Common.ExceptionHandler + VCSGui.Common.SetupConfig VCSGui.Common.Error VCSGui.Common.Commit + VCSGui.Mercurial.Commit VCSGui.Mercurial.Log + VCSGui.Common.Helpers + Paths_vcsgui + +executable vcsgui + main-is: Main.hs + build-depends: MissingH >=1.1.0.3 && <1.2, + filepath >=1.2.0.0 && < 1.3, + base >=4.0.0.0 && <4.4, + directory >=1.1.0.0 && <1.2, + haskell98 >=1.1.0.1 && <1.2, + mtl >=2.0.1.0 && <2.1, + vcswrapper ==0.0.1, + process >=1.0.1.5 && <1.1, + gtk >=0.12.0 && <0.13 + buildable: True + hs-source-dirs: src + other-modules: VCSGui.Svn.Helper VCSGui.Common.Process + VCSGui.Common.ConflictsResolved VCSGui.Common.MergeTool + VCSGui.Common.FilesInConflict VCSGui.Git.Pull VCSGui.Svn.Update + VCSGui.Svn.AskPassword VCSGui VCSGui.Svn.Log VCSGui.Svn.Checkout + VCSGui.Svn.Commit VCSGui.Git.Log VCSGui.Git.Helpers + VCSGui.Git.Commit VCSGui.Common.Log + VCSGui.Common.GtkHelper VCSGui.Common.ExceptionHandler + VCSGui.Common.SetupConfig VCSGui.Common.Error VCSGui.Common.Commit + VCSGui.Common.Helpers + Paths_vcsgui + +executable vcsgui-askpass + main-is: Main.hs + build-depends: MissingH >=1.1.0.3 && <1.2, + filepath >=1.2.0.0 && < 1.3, + base >=4.0.0.0 && <4.4, + directory >=1.1.0.0 && <1.2, + haskell98 >=1.1.0.1 && <1.2, + mtl >=2.0.1.0 && <2.1, + vcswrapper ==0.0.1, + process >=1.0.1.5 && <1.1, + gtk >=0.12.0 && <0.13 + buildable: True + hs-source-dirs: src/exe/askpass src + other-modules: VCSGui.Svn.Helper VCSGui.Common.Process + VCSGui.Common.ConflictsResolved VCSGui.Common.MergeTool + VCSGui.Common.FilesInConflict VCSGui.Git.Pull VCSGui.Svn.Update + VCSGui.Svn.AskPassword Paths_vcsgui VCSGui.Common.GtkHelper + VCSGui.Common.Helpers