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/ltk.cabal b/ltk.cabal new file mode 100644 --- /dev/null +++ b/ltk.cabal @@ -0,0 +1,53 @@ +name: ltk +version: 0.8 +cabal-version: -any +build-type: Simple +license: GPL +license-file: LICENSE +copyright: Juergen "jutaro" Nicklisch-Franken +maintainer: maintainer@leksah.org +build-depends: Cabal >=1.6.0, base >=4.0.0.0 && <5.0.0.0, + containers >=0.2, filepath >=1.1.0, glib >=0.10.0, gtk >=0.10.0, + mtl >=1.1.0.2, parsec >=2.1.0.1, pretty >=1.0.1.0 +stability: +homepage: http://www.leksah.org +package-url: http://code.haskell.org/ltk +bug-reports: http://code.google.com/p/leksah/issues/list +synopsis: Leksah tool kit +description: UI Framework used by leksah +category: GUI +author: Juergen "jutaro" Nicklisch-Franken +tested-with: GHC ==6.10 || ==6.12 +data-files: +data-dir: "" +extra-source-files: +extra-tmp-files: +exposed-modules: Default MyMissing Control.Event + Graphics.UI.Editor.Basics Graphics.UI.Editor.Composite + Graphics.UI.Editor.DescriptionPP Graphics.UI.Editor.MakeEditor + Graphics.UI.Editor.Parameters Graphics.UI.Editor.Simple + Graphics.UI.Frame.Panes Graphics.UI.Frame.ViewFrame + Text.PrinterParser +exposed: True +buildable: True +build-tools: +cpp-options: +cc-options: +ld-options: +pkgconfig-depends: +frameworks: +c-sources: +extensions: CPP +extra-libraries: +extra-lib-dirs: +includes: +install-includes: +include-dirs: +hs-source-dirs: src +other-modules: +ghc-prof-options: +ghc-shared-options: +ghc-options: +hugs-options: +nhc98-options: +jhc-options: diff --git a/src/Control/Event.hs b/src/Control/Event.hs new file mode 100644 --- /dev/null +++ b/src/Control/Event.hs @@ -0,0 +1,86 @@ +{-# OPTIONS_GHC -XMultiParamTypeClasses -XFunctionalDependencies #-} +----------------------------------------------------------------------------- +-- +-- Module : Control.Event +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : +-- Stability : provisional +-- Portability : portable +-- +-- | A simple event mechanism +-- +------------------------------------------------------------------------------- +module Control.Event ( + EventSelector +, Event(..) +, EventSource(..) +, Handlers +) where + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Unique +import Control.Monad + +-- | Every event needs a selector, which should identify the type of event +class (Eq delta, Ord delta, Show delta) => EventSelector delta + +-- | Every event needs to know its selector and its source +class EventSelector delta => Event beta delta | beta -> delta, delta -> beta where + getSelector :: beta -> delta + +-- | This shows the implementation of the event mechnism +type Handlers beta gamma delta = Map delta [(Unique, beta -> gamma beta)] + +-- | Everything which is an event source needs this +class (Monad gamma, Event beta delta) => EventSource alpha beta gamma delta + | alpha -> beta, alpha -> gamma where + getHandlers :: alpha -> gamma (Handlers beta gamma delta) + setHandlers :: alpha -> Handlers beta gamma delta -> gamma () + myUnique :: alpha -> gamma (Unique) + + -- | Reimplement this in instances to make triggering of events possible + canTriggerEvent :: alpha -> delta -> Bool + canTriggerEvent _ _ = False + + -- | Returns the event, so that you may get values back from an event + triggerEvent :: alpha -> beta -> gamma beta + triggerEvent o e = + if canTriggerEvent o (getSelector e) + then do + handlerMap <- getHandlers o + let selector = getSelector e + case selector `Map.lookup` handlerMap of + Nothing -> return e + Just l -> foldM (\e (_,ah) -> ah e) e (reverse l) + else error $ "Can't trigger event " ++ show (getSelector e) + + -- | use Left to register and Right to unregister + -- returns Unique if registration was successfull, else Nothing + registerEvent :: alpha -> delta + -> Either (beta -> gamma beta) Unique -> gamma (Maybe Unique) + registerEvent o e (Left handler) = + if canTriggerEvent o e + then do + handlerMap <- getHandlers o + unique <- myUnique o + let newHandlers = case e `Map.lookup` handlerMap of + Nothing -> Map.insert e [(unique,handler)] handlerMap + Just l -> Map.insert e ((unique,handler):l) handlerMap + setHandlers o newHandlers + return (Just unique) + else error $ "Can't register event " ++ show e + registerEvent o e (Right unique) = + if canTriggerEvent o e + then do + handlerMap <- getHandlers o + let newHandlers = case e `Map.lookup` handlerMap of + Nothing -> handlerMap + Just l -> let newList = filter (\ (mu,_) -> mu /= unique) l + in Map.insert e newList handlerMap + setHandlers o newHandlers + return (Just unique) + else error $ "Can't register event " ++ show e + diff --git a/src/Default.hs b/src/Default.hs new file mode 100644 --- /dev/null +++ b/src/Default.hs @@ -0,0 +1,46 @@ + +----------------------------------------------------------------------------- +-- +-- Module : Default +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : provisional +-- Portability : portable +-- +-- | Module for default values of a data type +-- +------------------------------------------------------------------------------ + +module Default ( + Default(..) +) where + +-- +-- | A class for providing default values for certain types of editors +-- +class Default alpha where + getDefault :: alpha + +instance Default Int where + getDefault = 1 + +instance Default alpha => Default (Either alpha beta) where + getDefault = Left getDefault + +instance (Default alpha, Default beta) => Default (alpha, beta) where + getDefault = (getDefault,getDefault) + +instance (Default alpha, Default beta, Default gamma) => Default (alpha, beta, gamma) where + getDefault = (getDefault,getDefault,getDefault) + +instance Default [alpha] where + getDefault = [] + +instance Default (Maybe alpha) where + getDefault = Nothing + +instance Default Bool where + getDefault = True + diff --git a/src/Graphics/UI/Editor/Basics.hs b/src/Graphics/UI/Editor/Basics.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Editor/Basics.hs @@ -0,0 +1,285 @@ +{-# OPTIONS_GHC -XMultiParamTypeClasses -XScopedTypeVariables #-} + +----------------------------------------------------------------------------- +-- +-- Module : Graphics.UI.Editor.Basics +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : +-- Stability : provisional +-- Portability : portable +-- +-- | Module for the basiscs of composing GUIs from editors +-- +----------------------------------------------------------------------------------- + +module Graphics.UI.Editor.Basics ( +-- * Types + Getter +, Setter +, Injector +, Extractor +, Applicator +, Editor +, getStandardRegFunction +, emptyNotifier +, GUIEvent(..) +, GUIEventSelector(..) +, GtkRegFunc +, Notifier(..) +, GtkHandler + +, activateEvent +, propagateEvent +, allGUIEvents +) where + +import Graphics.UI.Gtk +import qualified Graphics.UI.Gtk.Gdk.Events as Gtk +import Data.Unique +import Data.IORef +import Control.Monad + +import Graphics.UI.Editor.Parameters +import Control.Event +import Data.Map (Map(..)) +import qualified Data.Map as Map (delete,insert,lookup,empty) +import Data.Maybe (isJust,fromJust) +import Unsafe.Coerce (unsafeCoerce) +import Control.Arrow (first) +import MyMissing (allOf) + +-- --------------------------------------------------------------------- +-- * Basic Types +-- + +-- +-- | A type for getting a field of a record +-- +type Getter alpha beta = alpha -> beta +-- +-- | A type for setting the field of a record +-- +type Setter alpha beta = beta -> alpha -> alpha + +-- +-- | A type for injecting a value into an editor +-- +type Injector beta = beta -> IO () +-- +-- | A type for extracting a value from an editor +-- +type Extractor beta = IO (Maybe beta) +-- +-- | A type for the application of a value to be reflected in the GUI +-- +type Applicator beta gamma = beta -> gamma () + +-- +-- | A type to describe an editor. +-- alpha is the type of the individual field of the record +type Editor alpha = Parameters -> Notifier + -> IO(Widget, Injector alpha , Extractor alpha) + + +-- +-- | A type for an event in the GUI +-- +data GUIEvent = GUIEvent { + selector :: GUIEventSelector +, gtkEvent :: Gtk.Event +, eventPaneName :: String +, gtkReturn :: Bool -- ^ True means that the event has been completely handled, + -- gtk shoudn't do any further action about it (Often not + -- a good idea +} +instance Event GUIEvent GUIEventSelector where + getSelector = selector + +data GUIEventSelector = Clicked + | FocusOut + | FocusIn + | SelectionChanged + | ButtonRelease + | AfterKeyRelease + deriving (Eq,Ord,Show,Enum,Bounded) + +instance EventSelector GUIEventSelector + +allGUIEvents :: [GUIEventSelector] +allGUIEvents = allOf + +-- ------------------------------------------------------------ +-- * Implementation of GUI event system +-- ------------------------------------------------------------ + +-- | A type for handling an IO event +-- Returning True: The event has been handles +-- Returning False: Handling should proceed +type GtkHandler = Gtk.Event -> IO Bool + +-- +-- | A type for a function to register a gtk event +-- | +type GtkRegFunc = Widget -> GtkHandler -> IO (ConnectId Widget) + +-- +-- | The widgets are the real event sources. +-- The GtkRegFunc is the function used to register the event. +-- The connectIds are set, when the event is activated, and +-- can be used to deactivate the event. +-- Or it is a propagated event and: +-- The Notifier List is a list of event sources, to which registrations +-- are propageted. +-- The last map is used to unregister propagated events properly +-- +type GUIEventReg = ([ConnectId Widget], + ([Notifier], Map Unique [(Unique,Notifier)])) + +-- +-- | The event source in the gtk editor context +-- If the second argument is Left Handler the handler gets registered +-- If the second argument is Right Unique the handler will be removed +-- The returned unique value must be used for unregistering an event +newtype Notifier = Noti (IORef (Handlers GUIEvent IO GUIEventSelector, + Map GUIEventSelector GUIEventReg)) + + +emptyNotifier :: IO Notifier +emptyNotifier = do + h <- newIORef (Map.empty,Map.empty) + let noti = Noti h + return noti + +instance EventSource Notifier GUIEvent IO GUIEventSelector where + getHandlers (Noti pairRef) = do + (h,_) <- readIORef pairRef + return h + + setHandlers (Noti pairRef) h = do + (_,r) <- readIORef pairRef + writeIORef pairRef (h,r) + + myUnique _ = newUnique + + canTriggerEvent _ _ = True + + registerEvent o@(Noti pairRef) eventSel hand@(Left handler) = do + (handlers, ger) <- readIORef pairRef + unique <- myUnique o + newGer <- case Map.lookup eventSel ger of + Nothing -> return ger + Just (_,([],um)) -> return ger + Just (cids,(notifiers,um)) -> do + lu <- mapM (\es -> registerEvent es eventSel hand) + notifiers + let jl = map (first fromJust) + $ filter (isJust.fst) + $ zip lu notifiers + let newUm = Map.insert unique jl um + return (Map.insert eventSel (cids,(notifiers,newUm)) ger) + let newHandlers = case eventSel `Map.lookup` handlers of + Nothing -> Map.insert eventSel + [(unique,handler)] handlers + Just l -> Map.insert eventSel + ((unique,handler):l) handlers + writeIORef pairRef (newHandlers,newGer) + return (Just unique) + registerEvent o@(Noti pairRef) eventSel (Right unique) = do + (handlers, ger) <- readIORef pairRef + newGer <- case Map.lookup eventSel ger of + Nothing -> return ger + Just (cids,(notis,um)) -> + case unique `Map.lookup` um of + Nothing -> return ger + Just l -> do + mapM_ (\(u,es) -> registerEvent es eventSel (Right u)) l + let newUm = unique `Map.delete` um + return (Map.insert eventSel (cids,(notis,newUm)) ger) + let newHandlers = case eventSel `Map.lookup` handlers of + Nothing -> handlers + Just l -> case filter (\ (mu,_) -> mu /= unique) l of + [] -> Map.delete eventSel handlers + l -> Map.insert eventSel l handlers + writeIORef pairRef (newHandlers,newGer) + return (Just unique) + +-- +-- | Propagate the event with the selector from notifier to eventSource +-- +propagateEvent :: Notifier -> [Notifier] -> GUIEventSelector -> IO () +propagateEvent (Noti pairRef) eventSources eventSel = do + (handlers,ger) <- readIORef pairRef + let newGer = case Map.lookup eventSel ger of + Nothing -> Map.insert eventSel + ([],(eventSources,Map.empty)) ger + Just (w,(notiList,unregMap)) -> Map.insert eventSel + (w,(eventSources ++ notiList,unregMap)) ger + --now propagate already registered events + newGer2 <- case eventSel `Map.lookup` handlers of + Nothing -> return newGer + Just hl -> foldM (repropagate eventSel) newGer hl + writeIORef pairRef (handlers,newGer) + where + repropagate :: GUIEventSelector + -> Map GUIEventSelector GUIEventReg + -> (Unique, GUIEvent -> IO GUIEvent) + -> IO (Map GUIEventSelector GUIEventReg) + repropagate eventSet ger (unique,hand) = + case Map.lookup eventSel ger of + Just (cids,(notifiers,um)) + -> do + lu <- mapM (\es -> registerEvent es eventSel (Left hand)) + notifiers + let jl = map (first fromJust) + $ filter (isJust.fst) + $ zip lu notifiers + let newUm = Map.insert unique jl um + return (Map.insert eventSel (cids,(notifiers,newUm)) ger) + _ -> error "Basics>>propagateEvent: impossible case" + +-- +-- | Activate the event after the event has been declared and the +-- widget has been constructed +-- +activateEvent :: Widget -> Notifier -> Maybe GtkRegFunc -> GUIEventSelector -> IO() +activateEvent widget (Noti pairRef) mbRegisterFunc eventSel = do + let registerFunc = case mbRegisterFunc of + Just f -> f + Nothing -> getStandardRegFunction eventSel + cid <- registerFunc widget (\ e -> do + (hi,_) <- readIORef pairRef + case Map.lookup eventSel hi of + Nothing -> return False + Just [] -> return False + Just handlers -> do + name <- widgetGetName widget + eventList <- mapM (\f -> do + let ev = GUIEvent eventSel e name False + f ev) + (map snd handlers) + let boolList = map gtkReturn eventList + return (foldr (&&) True boolList)) + (handerls,ger) <- readIORef pairRef + let newGer = case Map.lookup eventSel ger of + Nothing -> Map.insert eventSel ([cid],([],Map.empty)) + ger + Just (cids,prop) -> + Map.insert eventSel (cid:cids,prop) ger + writeIORef pairRef (handerls,newGer) + +-- +-- | A convinence method for not repeating this over and over again +-- +getStandardRegFunction :: GUIEventSelector -> GtkRegFunc +getStandardRegFunction FocusOut = \w h -> w `onFocusOut` h +getStandardRegFunction FocusIn = \w h -> w `onFocusIn` h +getStandardRegFunction ButtonRelease = \w h -> w `onButtonRelease` h +getStandardRegFunction AfterKeyRelease = \w h -> w `afterKeyRelease` h +getStandardRegFunction Clicked = \w h -> do + res <- onClicked (castToButton w) (do + h (Gtk.Event True) + return ()) + return (unsafeCoerce res) +getStandardRegFunction SelectionChanged = error "yet not implemented" diff --git a/src/Graphics/UI/Editor/Composite.hs b/src/Graphics/UI/Editor/Composite.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Editor/Composite.hs @@ -0,0 +1,788 @@ +----------------------------------------------------------------------------- +-- +-- Module : Graphics.UI.Editor.Composite +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : +-- Stability : provisional +-- Portability : portable +-- +-- | Module for making composite editors +-- +----------------------------------------------------------------------------------- + +module Graphics.UI.Editor.Composite ( + maybeEditor +, pairEditor +, tupel3Editor +--, tupel4Editor +--, tupel5Editor +--, tupel6Editor +--, tupel7Editor +, splitEditor +, eitherOrEditor +, multisetEditor +, ColumnDescr(..) + +, filesEditor +, stringsEditor + +, versionEditor +, versionRangeEditor +, dependencyEditor +, dependenciesEditor +) where + +import Graphics.UI.Gtk +import Control.Monad +import Data.IORef +import Data.Maybe + +import Default +import Control.Event +import Graphics.UI.Editor.Parameters +import Graphics.UI.Editor.Basics +import Graphics.UI.Editor.MakeEditor +import Graphics.UI.Editor.Simple +import Data.List (sortBy, nub, sort, elemIndex) +import Distribution.Simple + (orEarlierVersion, + orLaterVersion, + VersionRange(..), + PackageName(..), + Dependency(..), + PackageIdentifier(..)) +import Distribution.Text (simpleParse, display) +import Distribution.Package (pkgName) +import Data.Version (Version(..)) +import MyMissing (forceJust) + +-- +-- | An editor which composes two subeditors +-- +pairEditor :: (Editor alpha, Parameters) -> (Editor beta, Parameters) -> Editor (alpha,beta) +pairEditor (fstEd,fstPara) (sndEd,sndPara) parameters notifier = do + coreRef <- newIORef Nothing + noti1 <- emptyNotifier + noti2 <- emptyNotifier + mapM_ (propagateEvent notifier [noti2]) allGUIEvents + fst@(fstFrame,inj1,ext1) <- fstEd fstPara noti1 + snd@(sndFrame,inj2,ext2) <- sndEd sndPara noti2 + mkEditor + (\widget (v1,v2) -> do + core <- readIORef coreRef + case core of + Nothing -> do + box <- case getParameter paraDirection parameters of + Horizontal -> do + b <- hBoxNew False 1 + return (castToBox b) + Vertical -> do + b <- vBoxNew False 1 + return (castToBox b) + boxPackStart box fstFrame PackGrow 0 + boxPackStart box sndFrame PackGrow 0 + containerAdd widget box + inj1 v1 + inj2 v2 + writeIORef coreRef (Just (fst,snd)) + Just ((_,inj1,_),(_,inj2,_)) -> do + inj1 v1 + inj2 v2) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just ((_,_,ext1),(_,_,ext2)) -> do + r1 <- ext1 + r2 <- ext2 + if isJust r1 && isJust r2 + then return (Just (fromJust r1,fromJust r2)) + else return Nothing) + parameters + notifier + +tupel3Editor :: (Editor alpha, Parameters) + -> (Editor beta, Parameters) + -> (Editor gamma, Parameters) + -> Editor (alpha,beta,gamma) +tupel3Editor p1 p2 p3 parameters notifier = do + coreRef <- newIORef Nothing + noti1 <- emptyNotifier + noti2 <- emptyNotifier + noti3 <- emptyNotifier + mapM_ (propagateEvent notifier [noti2]) allGUIEvents + r1@(frame1,inj1,ext1) <- (fst p1) (snd p1) noti1 + r2@(frame2,inj2,ext2) <- (fst p2) (snd p2) noti2 + r3@(frame3,inj3,ext3) <- (fst p3) (snd p3) noti3 + mkEditor + (\widget (v1,v2,v3) -> do + core <- readIORef coreRef + case core of + Nothing -> do + box <- case getParameter paraDirection parameters of + Horizontal -> do + b <- hBoxNew False 1 + return (castToBox b) + Vertical -> do + b <- vBoxNew False 1 + return (castToBox b) + boxPackStart box frame1 PackGrow 0 + boxPackStart box frame2 PackGrow 0 + boxPackStart box frame3 PackGrow 0 + containerAdd widget box + inj1 v1 + inj2 v2 + inj3 v3 + writeIORef coreRef (Just (r1,r2,r3)) + Just ((_,inj1,_),(_,inj2,_),(_,inj3,_)) -> do + inj1 v1 + inj2 v2 + inj3 v3) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just ((_,_,ext1),(_,_,ext2),(_,_,ext3)) -> do + r1 <- ext1 + r2 <- ext2 + r3 <- ext3 + if isJust r1 && isJust r2 && isJust r3 + then return (Just (fromJust r1,fromJust r2, fromJust r3)) + else return Nothing) + parameters + notifier + +{-- +tupel4Editor :: (Editor alpha, Parameters) + -> (Editor beta, Parameters) + -> (Editor gamma, Parameters) + -> (Editor delta, Parameters) + -> Editor (alpha,beta,gamma,delta) +tupel4Editor p1 p2 p3 p4 parameters notifier = do + (widg,inj,ext) <- pairEditor ((tupel3Editor p1 p2 p3), parameters) p4 parameters notifier + return (widg, + (\ (a, b, c, d) -> inj ((a,b,c),d)), + (do + mb <- ext + case mb of + Nothing -> return Nothing + Just ((a,b,c),d) -> return (Just (a,b,c,d)))) + +tupel5Editor :: (Editor alpha, Parameters) + -> (Editor beta, Parameters) + -> (Editor gamma, Parameters) + -> (Editor delta, Parameters) + -> (Editor epsilon, Parameters) + -> Editor (alpha,beta,gamma,delta,epsilon) +tupel5Editor p1 p2 p3 p4 p5 parameters notifier = do + (widg,inj,ext) <- pairEditor ((tupel4Editor p1 p2 p3 p4), parameters) p5 parameters notifier + return (widg, + (\ (a, b, c, d, e) -> inj ((a,b,c,d),e)), + (do + mb <- ext + case mb of + Nothing -> return Nothing + Just ((a,b,c,d),e) -> return (Just (a,b,c,d,e)))) + +tupel6Editor :: (Editor alpha, Parameters) + -> (Editor beta, Parameters) + -> (Editor gamma, Parameters) + -> (Editor delta, Parameters) + -> (Editor epsilon, Parameters) + -> (Editor zeta, Parameters) + -> Editor (alpha,beta,gamma,delta,epsilon,zeta) +tupel6Editor p1 p2 p3 p4 p5 p6 parameters notifier = do + (widg,inj,ext) <- pairEditor ((tupel5Editor p1 p2 p3 p4 p5), parameters) p6 parameters notifier + return (widg, + (\ (a, b, c, d, e, f) -> inj ((a,b,c,d,e),f)), + (do + mb <- ext + case mb of + Nothing -> return Nothing + Just ((a,b,c,d,e),f) -> return (Just (a,b,c,d,e,f)))) + +tupel7Editor :: (Editor alpha, Parameters) + -> (Editor beta, Parameters) + -> (Editor gamma, Parameters) + -> (Editor delta, Parameters) + -> (Editor epsilon, Parameters) + -> (Editor zeta, Parameters) + -> (Editor eta, Parameters) + -> Editor (alpha,beta,gamma,delta,epsilon,zeta,eta) +tupel7Editor p1 p2 p3 p4 p5 p6 p7 parameters notifier = do + (widg,inj,ext) <- pairEditor ((tupel6Editor p1 p2 p3 p4 p5 p6), parameters) p7 parameters notifier + return (widg, + (\ (a, b, c, d, e, f, g) -> inj ((a,b,c,d,e,f),g)), + (do + mb <- ext + case mb of + Nothing -> return Nothing + Just ((a,b,c,d,e,f),g) -> return (Just (a,b,c,d,e,f,g)))) +--} + +-- +-- | Like a pair editor, but with a moveable split +-- +splitEditor :: (Editor alpha, Parameters) -> (Editor beta, Parameters) -> Editor (alpha,beta) +splitEditor (fstEd,fstPara) (sndEd,sndPara) parameters notifier = do + coreRef <- newIORef Nothing + noti1 <- emptyNotifier + noti2 <- emptyNotifier + mapM_ (propagateEvent notifier [noti1,noti2]) allGUIEvents + fst@(fstFrame,inj1,ext1) <- fstEd fstPara noti1 + snd@(sndFrame,inj2,ext2) <- sndEd sndPara noti2 + mkEditor + (\widget (v1,v2) -> do + core <- readIORef coreRef + case core of + Nothing -> do + paned <- case getParameter paraDirection parameters of + Horizontal -> do h <- vPanedNew + return (castToPaned h) + Vertical -> do v <- hPanedNew + return (castToPaned v) + panedPack1 paned fstFrame True True + panedPack2 paned sndFrame True True + containerAdd widget paned + inj1 v1 + inj2 v2 + writeIORef coreRef (Just (fst,snd)) + Just ((_,inj1,_),(_,inj2,_)) -> do + inj1 v1 + inj2 v2) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just ((_,_,ext1),(_,_,ext2)) -> do + r1 <- ext1 + r2 <- ext2 + if isJust r1 && isJust r2 + then return (Just (fromJust r1,fromJust r2)) + else return Nothing) + parameters + notifier + +-- +-- | An editor with a subeditor which gets active, when a checkbox is selected +-- or deselected (if the positive Argument is False) +-- +maybeEditor :: Default beta => (Editor beta, Parameters) -> Bool -> String -> Editor (Maybe beta) +maybeEditor (childEdit, childParams) positive boolLabel parameters notifier = do + coreRef <- newIORef Nothing + childRef <- newIORef Nothing + notifierBool <- emptyNotifier + cNoti <- emptyNotifier + mapM_ (propagateEvent notifier [notifierBool]) [Clicked,FocusIn] + mapM_ (propagateEvent notifier [cNoti]) allGUIEvents + + mkEditor + (\widget mbVal -> do + core <- readIORef coreRef + case core of + Nothing -> do + box <- case getParameter paraDirection parameters of + Horizontal -> do + b <- hBoxNew False 1 + return (castToBox b) + Vertical -> do + b <- vBoxNew False 1 + return (castToBox b) + be@(boolFrame,inj1,ext1) <- boolEditor + (paraName <<<- ParaName boolLabel $ emptyParams) + notifierBool + boxPackStart box boolFrame PackNatural 0 + containerAdd widget box + registerEvent notifierBool Clicked (Left (onClickedHandler widget coreRef childRef cNoti)) + case mbVal of + Nothing -> inj1 (not positive) + Just val -> do + (childWidget,inj2,ext2) <- getChildEditor childRef childEdit childParams cNoti + boxPackEnd box childWidget PackGrow 0 + widgetShowAll childWidget + inj1 positive + inj2 val + writeIORef coreRef (Just (be,box)) + Just (be@(boolFrame,inj1,extt),box) -> do + hasChild <- hasChildEditor childRef + case mbVal of + Nothing -> + if hasChild + then do + (childWidget,_,_) <- getChildEditor childRef childEdit childParams cNoti + inj1 (not positive) + widgetHideAll childWidget + else inj1 (not positive) + Just val -> + if hasChild + then do + inj1 positive + (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti + widgetShowAll childWidget + inj2 val + else do + inj1 positive + (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti + boxPackEnd box childWidget PackGrow 0 + widgetShowAll childWidget + inj2 val) + (do + core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just (be@(boolFrame,inj1,ext1),_) -> do + bool <- ext1 + case bool of + Nothing -> return Nothing + Just bv | bv == positive -> do + (_,_,ext2) <- getChildEditor childRef childEdit childParams cNoti + value <- ext2 + case value of + Nothing -> return Nothing + Just value -> return (Just (Just value)) + otherwise -> return (Just Nothing)) + parameters + notifier + where + onClickedHandler widget coreRef childRef cNoti event = do + core <- readIORef coreRef + case core of + Nothing -> error "Impossible" + Just (be@(boolFrame,inj1,ext1),vBox) -> do + mbBool <- ext1 + case mbBool of + Just bool -> + if bool /= positive + then do + hasChild <- hasChildEditor childRef + when hasChild $ do + (childWidget,_,_) <- getChildEditor childRef childEdit childParams cNoti + widgetHideAll childWidget + else do + hasChild <- hasChildEditor childRef + if hasChild + then do + (childWidget,_,_) <- getChildEditor childRef childEdit childParams cNoti + widgetShowAll childWidget + else do + (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti + boxPackEnd vBox childWidget PackNatural 0 + inj2 getDefault + widgetShowAll childWidget + Nothing -> return () + return (event {gtkReturn=True}) + getChildEditor childRef childEditor childParams cNoti = do + mb <- readIORef childRef + case mb of + Just editor -> return editor + Nothing -> do + let val = childEditor + editor@(_,_,_) <- childEditor childParams cNoti + writeIORef childRef (Just editor) + return editor + hasChildEditor childRef = do + mb <- readIORef childRef + return (isJust mb) + +-- +-- | An editor with a subeditor which gets active, when a checkbox is selected +-- or deselected (if the positive Argument is False) +eitherOrEditor :: (Default alpha, Default beta) => (Editor alpha, Parameters) -> + (Editor beta, Parameters) -> String -> Editor (Either alpha beta) +eitherOrEditor (leftEditor,leftParams) (rightEditor,rightParams) + label2 parameters notifier = do + coreRef <- newIORef Nothing + noti1 <- emptyNotifier + noti2 <- emptyNotifier + noti3 <- emptyNotifier + mapM_ (propagateEvent notifier [noti1,noti2,noti3]) allGUIEvents + be@(boolFrame,inj1,ext1) <- boolEditor2 (getParameter paraName rightParams) leftParams noti1 + le@(leftFrame,inj2,ext2) <- leftEditor (paraName <<<- ParaName "" $ leftParams) noti2 + re@(rightFrame,inj3,ext3) <- rightEditor (paraName <<<- ParaName "" $ rightParams) noti3 + mkEditor + (\widget v -> do + core <- readIORef coreRef + case core of + Nothing -> do + registerEvent noti1 Clicked (Left (onClickedHandler widget coreRef)) + box <- case getParameter paraDirection parameters of + Horizontal -> do + b <- hBoxNew False 1 + return (castToBox b) + Vertical -> do + b <- vBoxNew False 1 + return (castToBox b) + boxPackStart box boolFrame PackNatural 0 + containerAdd widget box + case v of + Left vl -> do + boxPackStart box leftFrame PackNatural 0 + inj2 vl + inj3 getDefault + inj1 True + Right vr -> do + boxPackStart box rightFrame PackNatural 0 + inj3 vr + inj2 getDefault + inj1 False + writeIORef coreRef (Just (be,le,re,box)) + Just ((_,inj1,_),(leftFrame,inj2,_),(rightFrame,inj3,_),box) -> + case v of + Left vl -> do + containerRemove box rightFrame + boxPackStart box leftFrame PackNatural 0 + inj2 vl + inj3 getDefault + inj1 True + Right vr -> do + containerRemove box leftFrame + boxPackStart box rightFrame PackNatural 0 + inj3 vr + inj2 getDefault + inj1 False) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just ((_,_,ext1),(_,_,ext2),(_,_,ext3),_) -> do + mbbool <- ext1 + case mbbool of + Nothing -> return Nothing + Just True -> do + value <- ext2 + case value of + Nothing -> return Nothing + Just value -> return (Just (Left value)) + Just False -> do + value <- ext3 + case value of + Nothing -> return Nothing + Just value -> return (Just (Right value))) + (paraName <<<- ParaName "" $ parameters) + notifier + where + onClickedHandler widget coreRef event = do + core <- readIORef coreRef + case core of + Nothing -> error "Impossible" + Just (be@(_,_,ext1),(leftFrame,_,_),(rightFrame,_,_),box) -> do + mbBool <- ext1 + case mbBool of + Just bool -> + if bool then do + containerRemove box rightFrame + boxPackStart box leftFrame PackNatural 0 + widgetShowAll box + else do + containerRemove box leftFrame + boxPackStart box rightFrame PackNatural 0 + widgetShowAll box + Nothing -> return () + return event{gtkReturn=True} + + +-- a trivial example: (ColumnDescr False [("",(\row -> [cellText := show row]))]) +-- and a nontrivial: +-- [("Package",\(Dependency str _) -> [cellText := str]) +-- ,("Version",\(Dependency _ vers) -> [cellText := showVersionRange vers])]) +data ColumnDescr row = ColumnDescr Bool [(String,(row -> [AttrOp CellRendererText]))] + +-- +-- | An editor with a subeditor, of which a list of items can be selected +multisetEditor :: (Show alpha, Default alpha, Eq alpha) => ColumnDescr alpha + -> (Editor alpha, Parameters) + -> Maybe ([alpha] -> [alpha]) -- ^ The 'mbSort' arg, a sort function if desired + -> Maybe (alpha -> alpha -> Bool) -- ^ The 'mbReplace' arg, a function which is a criteria for removing an + -- old entry when adding a new value + -> Editor [alpha] +multisetEditor (ColumnDescr showHeaders columnsDD) (singleEditor, sParams) mbSort mbReplace + parameters notifier = do + coreRef <- newIORef Nothing + cnoti <- emptyNotifier + mapM_ (propagateEvent notifier [cnoti]) allGUIEvents + mkEditor + (\widget vs -> do + core <- readIORef coreRef + case core of + Nothing -> do + (box,buttonBox) <- case getParameter paraDirection parameters of + Horizontal -> do + b <- hBoxNew False 1 + bb <- vButtonBoxNew + return (castToBox b,castToButtonBox bb) + Vertical -> do + b <- vBoxNew False 1 + bb <- hButtonBoxNew + return (castToBox b,castToButtonBox bb) + (frameS,injS,extS) <- singleEditor sParams cnoti + addButton <- buttonNewWithLabel "Add" + removeButton <- buttonNewWithLabel "Remove" + containerAdd buttonBox addButton + containerAdd buttonBox removeButton + listStore <- listStoreNew ([]:: [alpha]) + treeView <- treeViewNewWithModel listStore + let minSize = getParameter paraMinSize parameters + uncurry (widgetSetSizeRequest treeView) minSize + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw treeView + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + sel <- treeViewGetSelection treeView + treeSelectionSetMode sel SelectionSingle + mapM_ (\(str,func) -> do + col <- treeViewColumnNew + treeViewColumnSetTitle col str + treeViewColumnSetResizable col True + treeViewAppendColumn treeView col + renderer <- cellRendererTextNew + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer listStore func + ) columnsDD + treeViewSetHeadersVisible treeView showHeaders + sel `onSelectionChanged` selectionHandler sel listStore injS + boxPackStart box sw PackGrow 0 + boxPackStart box buttonBox PackNatural 0 + boxPackStart box frameS PackNatural 0 + activateEvent (castToWidget treeView) notifier Nothing FocusOut + containerAdd widget box + listStoreClear listStore + mapM_ (listStoreAppend listStore) + (case mbSort of + Nothing -> vs + Just sortF -> sortF vs) + addButton `onClicked` do + mbv <- extS + case mbv of + Just v -> do + case mbReplace of + Nothing -> return () + Just replaceF -> do + cont <- listStoreToList listStore + mapM_ (listStoreRemove listStore) + $ map fst + $ filter (\(_,e) -> replaceF v e) + $ zip [0..] cont + case mbSort of + Nothing -> do + listStoreAppend listStore v + return () + Just sortF -> do + cont <- listStoreToList listStore + listStoreClear listStore + mapM_ (listStoreAppend listStore) (sortF (v:cont)) + cont <- listStoreToList listStore + case elemIndex v cont of + Just idx -> do + treeSelectionSelectPath sel [idx] + mbCol <- treeViewGetColumn treeView 0 + case mbCol of + Nothing -> return () + Just col -> treeViewScrollToCell treeView [idx] col Nothing + Nothing -> return () + Nothing -> return () + removeButton `onClicked` do + mbi <- treeSelectionGetSelected sel + case mbi of + Nothing -> return () + Just iter -> do + [i] <- treeModelGetPath listStore iter + listStoreRemove listStore i + writeIORef coreRef (Just listStore) + injS getDefault + Just listStore -> do + listStoreClear listStore + mapM_ (listStoreAppend listStore) + (case mbSort of + Nothing -> vs + Just sortF -> sortF vs)) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just listStore -> do + v <- listStoreToList listStore + return (Just v)) + (paraMinSize <<<- ParaMinSize (-1,-1) $ parameters) + notifier + where + selectionHandler :: TreeSelection -> ListStore a -> Injector a -> IO () + selectionHandler sel listStore inj = do + ts <- treeSelectionGetSelected sel + case ts of + Nothing -> return () + Just iter -> do + [i] <- treeModelGetPath listStore iter + v <- listStoreGetValue listStore i + inj v + return () + + +filesEditor :: Maybe FilePath -> FileChooserAction -> String -> Editor [FilePath] +filesEditor fp act label p = + multisetEditor + (ColumnDescr False [("",(\row -> [cellText := row]))]) + (fileEditor fp act label, emptyParams) + (Just sort) + (Just (==)) + (paraShadow <<<- ParaShadow ShadowIn $ + paraDirection <<<- ParaDirection Vertical $ p) + +stringsEditor :: (String -> Bool) -> Editor [String] +stringsEditor validation p = + multisetEditor + (ColumnDescr False [("",(\row -> [cellText := row]))]) + (stringEditor validation, emptyParams) + (Just sort) + (Just (==)) + (paraShadow <<<- ParaShadow ShadowIn $ p) + +dependencyEditor :: [PackageIdentifier] -> Editor Dependency +dependencyEditor packages para noti = do + (wid,inj,ext) <- pairEditor + ((eitherOrEditor (comboSelectionEditor ((sort . nub) (map (display . pkgName) packages)) id + , paraName <<<- ParaName "Select" $ emptyParams) + (stringEditor (const True), paraName <<<- ParaName "Enter" $ emptyParams) + "Select from list?"), paraName <<<- ParaName "Name"$ emptyParams) + (versionRangeEditor,paraName <<<- ParaName "Version" $ emptyParams) + (paraDirection <<<- ParaDirection Vertical $ para) + noti + let pinj (Dependency pn@(PackageName s) v) = if elem s (map (display . pkgName) packages) + then inj (Left s,v) + else inj (Right s,v) + let pext = do + mbp <- ext + case mbp of + Nothing -> return Nothing + Just (Left "",v) -> return Nothing + Just (Left s,v) -> return (Just $ Dependency (PackageName s) v) + Just (Right "",v) -> return Nothing + Just (Right s,v) -> return (Just $ Dependency (PackageName s) v) + return (wid,pinj,pext) + +dependenciesEditor :: [PackageIdentifier] -> Editor [Dependency] +dependenciesEditor packages p noti = + multisetEditor + (ColumnDescr True [("Package",\(Dependency (PackageName str) _) -> [cellText := str]) + ,("Version",\(Dependency _ vers) -> [cellText := display vers])]) + (dependencyEditor packages, + paraOuterAlignment <<<- ParaInnerAlignment (0.0, 0.5, 1.0, 1.0) + $ paraInnerAlignment <<<- ParaOuterAlignment (0.0, 0.5, 1.0, 1.0) + $ emptyParams) + (Just (sortBy (\ (Dependency p1 _) (Dependency p2 _) -> compare p1 p2))) + (Just (\ (Dependency p1 _) (Dependency p2 _) -> p1 == p2)) + (paraShadow <<<- ParaShadow ShadowIn + $ paraOuterAlignment <<<- ParaInnerAlignment (0.0, 0.5, 1.0, 1.0) + $ paraInnerAlignment <<<- ParaOuterAlignment (0.0, 0.5, 1.0, 1.0) + $ paraDirection <<<- ParaDirection Vertical + $ paraPack <<<- ParaPack PackGrow + $ p) + noti + +versionRangeEditor :: Editor VersionRange +versionRangeEditor para noti = do + (wid,inj,ext) <- + maybeEditor + ((eitherOrEditor + (pairEditor + (comboSelectionEditor v1 show, emptyParams) + (versionEditor, paraName <<<- ParaName "Enter Version" $ emptyParams), + (paraDirection <<<- ParaDirection Vertical + $ paraName <<<- ParaName "Simple" + $ paraOuterAlignment <<<- ParaOuterAlignment (0.0, 0.0, 0.0, 0.0) + $ paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0) + $ paraInnerAlignment <<<- ParaInnerAlignment (0.0, 0.0, 0.0, 0.0) + $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0) + $ emptyParams)) + (tupel3Editor + (comboSelectionEditor v2 show, emptyParams) + (versionRangeEditor, paraShadow <<<- ParaShadow ShadowIn $ emptyParams) + (versionRangeEditor, paraShadow <<<- ParaShadow ShadowIn $ emptyParams), + paraName <<<- ParaName "Complex" + $ paraDirection <<<- ParaDirection Vertical + $ paraOuterAlignment <<<- ParaOuterAlignment (0.0, 0.0, 0.0, 0.0) + $ paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0) + $ paraInnerAlignment <<<- ParaInnerAlignment (0.0, 0.0, 0.0, 0.0) + $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0) + $ emptyParams) "Select version range"), emptyParams) + False "Any Version" + (paraDirection <<<- ParaDirection Vertical $ para) + noti + let vrinj AnyVersion = inj Nothing + vrinj (ThisVersion v) = inj (Just (Left (ThisVersionS,v))) + vrinj (LaterVersion v) = inj (Just (Left (LaterVersionS,v))) + vrinj (EarlierVersion v) = inj (Just (Left (EarlierVersionS,v))) + vrinj (UnionVersionRanges (ThisVersion v1) (LaterVersion v2)) | v1 == v2 + = inj (Just (Left (ThisOrLaterVersionS,v1))) + vrinj (UnionVersionRanges (LaterVersion v1) (ThisVersion v2)) | v1 == v2 + = inj (Just (Left (ThisOrLaterVersionS,v1))) + vrinj (UnionVersionRanges (ThisVersion v1) (EarlierVersion v2)) | v1 == v2 + = inj (Just (Left (ThisOrEarlierVersionS,v1))) + vrinj (UnionVersionRanges (EarlierVersion v1) (ThisVersion v2)) | v1 == v2 + = inj (Just (Left (ThisOrEarlierVersionS,v1))) + vrinj (UnionVersionRanges v1 v2)= inj (Just (Right (UnionVersionRangesS,v1,v2))) + vrinj (IntersectVersionRanges v1 v2) + = inj (Just (Right (IntersectVersionRangesS,v1,v2))) + let vrext = do mvr <- ext + case mvr of + Nothing -> return (Just AnyVersion) + Just Nothing -> return (Just AnyVersion) + Just (Just (Left (ThisVersionS,v))) -> return (Just (ThisVersion v)) + Just (Just (Left (LaterVersionS,v))) -> return (Just (LaterVersion v)) + Just (Just (Left (EarlierVersionS,v))) -> return (Just (EarlierVersion v)) + + Just (Just (Left (ThisOrLaterVersionS,v))) -> return (Just (orLaterVersion v)) + Just (Just (Left (ThisOrEarlierVersionS,v))) -> return (Just (orEarlierVersion v)) + Just (Just (Right (UnionVersionRangesS,v1,v2))) + -> return (Just (UnionVersionRanges v1 v2)) + Just (Just (Right (IntersectVersionRangesS,v1,v2))) + -> return (Just (IntersectVersionRanges v1 v2)) + return (wid,vrinj,vrext) + where + v1 = [ThisVersionS,LaterVersionS,ThisOrLaterVersionS,EarlierVersionS,ThisOrEarlierVersionS] + v2 = [UnionVersionRangesS,IntersectVersionRangesS] + +data Version1 = ThisVersionS | LaterVersionS | ThisOrLaterVersionS | EarlierVersionS | ThisOrEarlierVersionS + deriving (Eq) +instance Show Version1 where + show ThisVersionS = "This Version" + show LaterVersionS = "Later Version" + show ThisOrLaterVersionS = "This or later Version" + show EarlierVersionS = "Earlier Version" + show ThisOrEarlierVersionS = "This or earlier Version" + +data Version2 = UnionVersionRangesS | IntersectVersionRangesS + deriving (Eq) +instance Show Version2 where + show UnionVersionRangesS = "Union Version Ranges" + show IntersectVersionRangesS = "Intersect Version Ranges" + +versionEditor :: Editor Version +versionEditor para noti = do + (wid,inj,ext) <- stringEditor (\s -> not (null s)) para noti + let pinj v = inj (display v) + let pext = do + s <- ext + case s of + Nothing -> return Nothing + Just s -> return (simpleParse s) + return (wid, pinj, pext) + +instance Default Version1 + where getDefault = ThisVersionS + +instance Default Version2 + where getDefault = UnionVersionRangesS + +instance Default Version + where getDefault = forceJust (simpleParse "0") "PackageEditor>>default version" + +instance Default VersionRange + where getDefault = AnyVersion + +instance Default Dependency + where getDefault = Dependency getDefault getDefault + +instance Default PackageName + where getDefault = PackageName getDefault + + + + + + diff --git a/src/Graphics/UI/Editor/DescriptionPP.hs b/src/Graphics/UI/Editor/DescriptionPP.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Editor/DescriptionPP.hs @@ -0,0 +1,100 @@ +----------------------------------------------------------------------------- +-- +-- Module : Graphics.UI.Editor.DescriptionPP +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : +-- Stability : provisional +-- Portability : portable +-- +-- | Description of a editor with additional fileds for printing and parsing +-- +----------------------------------------------------------------------------------- +module Graphics.UI.Editor.DescriptionPP ( + Applicator +, FieldDescriptionPP(..) +, mkFieldPP +, extractFieldDescription +, flattenFieldDescriptionPP +, flattenFieldDescriptionPPToS +) where + +import Graphics.UI.Gtk +import Control.Monad +import qualified Text.PrettyPrint.HughesPJ as PP +import qualified Text.ParserCombinators.Parsec as P + +import Text.PrinterParser hiding (fieldParser,parameters) +import Graphics.UI.Editor.Parameters +import Graphics.UI.Editor.MakeEditor +--import IDE.Core.State +import Graphics.UI.Editor.Basics (Applicator(..),Editor(..),Setter(..),Getter(..),Notifier(..),Extractor(..),Injector(..)) + +data FieldDescriptionPP alpha gamma = FDPP { + parameters :: Parameters + , fieldPrinter :: alpha -> PP.Doc + , fieldParser :: alpha -> P.CharParser () alpha + , fieldEditor :: alpha -> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier) + , applicator :: alpha -> alpha -> gamma ()} + | VFDPP Parameters [FieldDescriptionPP alpha gamma] + | HFDPP Parameters [FieldDescriptionPP alpha gamma] + | NFDPP [(String,FieldDescriptionPP alpha gamma)] + +type MkFieldDescriptionPP alpha beta gamma = + Parameters -> + (Printer beta) -> + (Parser beta) -> + (Getter alpha beta) -> + (Setter alpha beta) -> + (Editor beta) -> + (Applicator beta gamma ) -> + FieldDescriptionPP alpha gamma + +mkFieldPP :: (Eq beta, Monad gamma) => MkFieldDescriptionPP alpha beta gamma +mkFieldPP parameters printer parser getter setter editor applicator = + let FD _ ed = mkField parameters getter setter editor + in FDPP parameters + (\ dat -> (PP.text (case getParameterPrim paraName parameters of + Nothing -> "" + Just str -> str) PP.<> PP.colon) + PP.$$ (PP.nest 15 (printer (getter dat))) + PP.$$ (PP.nest 5 (case getParameterPrim paraSynopsis parameters of + Nothing -> PP.empty + Just str -> PP.text $"--" ++ str))) + (\ dat -> P.try (do + symbol (case getParameterPrim paraName parameters of + Nothing -> "" + Just str -> str) + colon + val <- parser + return (setter val dat))) + ed + (\ newDat oldDat -> do --applicator + let newField = getter newDat + let oldField = getter oldDat + if newField == oldField + then return () + else applicator newField) + +extractFieldDescription :: FieldDescriptionPP alpha gamma -> FieldDescription alpha +extractFieldDescription (VFDPP paras descrs) = VFD paras (map extractFieldDescription descrs) +extractFieldDescription (HFDPP paras descrs) = HFD paras (map extractFieldDescription descrs) +extractFieldDescription (NFDPP descrsp) = NFD (map (\(s,d) -> + (s, extractFieldDescription d)) descrsp) +extractFieldDescription (FDPP parameters fieldPrinter fieldParser fieldEditor applicator) = + (FD parameters fieldEditor) + +flattenFieldDescriptionPP :: FieldDescriptionPP alpha gamma -> [FieldDescriptionPP alpha gamma] +flattenFieldDescriptionPP (VFDPP paras descrs) = concatMap flattenFieldDescriptionPP descrs +flattenFieldDescriptionPP (HFDPP paras descrs) = concatMap flattenFieldDescriptionPP descrs +flattenFieldDescriptionPP (NFDPP descrsp) = concatMap (flattenFieldDescriptionPP . snd) descrsp +flattenFieldDescriptionPP fdpp = [fdpp] + +flattenFieldDescriptionPPToS :: FieldDescriptionPP alpha gamma -> [FieldDescriptionS alpha] +flattenFieldDescriptionPPToS = map ppToS . flattenFieldDescriptionPP + +ppToS :: FieldDescriptionPP alpha gamma -> FieldDescriptionS alpha +ppToS (FDPP para print pars _ _) = FDS para print pars +ppToS _ = error "DescriptionPP.ppToS Can't transform" + diff --git a/src/Graphics/UI/Editor/MakeEditor.hs b/src/Graphics/UI/Editor/MakeEditor.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Editor/MakeEditor.hs @@ -0,0 +1,258 @@ +----------------------------------------------------------------------------- +--group_Test +-- Module : Graphics.UI.Editor.MakeEditor +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : +-- Stability : provisional +-- Portability : portable +-- +-- | Module for making editors out of descriptions +-- +----------------------------------------------------------------------------------- + +module Graphics.UI.Editor.MakeEditor ( + + buildEditor +, FieldDescription(..) +, mkField +, extractAndValidate +, extract +, mkEditor +, parameters + +, flattenFieldDescription +, getRealWidget +, MkFieldDescription + +) where + +import Graphics.UI.Gtk +import Control.Monad +import Data.List(unzip4) + +import Control.Event +import Graphics.UI.Editor.Parameters +import Graphics.UI.Editor.Basics +--import Graphics.UI.Frame.ViewFrame +import Data.Maybe (isNothing) + +-- +-- | A constructor type for a field desciption +-- +type MkFieldDescription alpha beta = + Parameters -> + (Getter alpha beta) -> + (Setter alpha beta) -> + (Editor beta) -> + FieldDescription alpha + +-- +-- | A type to describe a field of a record, which can be edited +-- | alpha is the type of the individual field of the record +data FieldDescription alpha = FD Parameters (alpha -> IO (Widget, Injector alpha , + alpha -> Extractor alpha , Notifier)) + | VFD Parameters [FieldDescription alpha] + | HFD Parameters [FieldDescription alpha] + | NFD [(String,FieldDescription alpha)] + +parameters :: FieldDescription alpha -> Parameters +parameters (FD p _) = p +parameters (VFD p _) = p +parameters (HFD p _) = p +parameters (NFD _) = emptyParams + +-- +-- | Construct a new notebook +-- +newNotebook :: IO Notebook +newNotebook = do + nb <- notebookNew + notebookSetTabPos nb PosTop + notebookSetShowTabs nb True + notebookSetScrollable nb True + notebookSetPopup nb True + return nb + +buildEditor :: FieldDescription alpha -> alpha -> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier) +buildEditor (FD paras editorf) v = editorf v +buildEditor (HFD paras descrs) v = buildBoxEditor descrs Horizontal v +buildEditor (VFD paras descrs) v = buildBoxEditor descrs Vertical v +buildEditor (NFD pairList) v = do + nb <- newNotebook + notebookSetShowTabs nb False + resList <- mapM (\d -> buildEditor d v) (map snd pairList) + let (widgets, setInjs, getExts, notifiers) = unzip4 resList + notifier <- emptyNotifier + mapM_ (\ (labelString, widget) -> do + sw <- scrolledWindowNew Nothing Nothing + scrolledWindowAddWithViewport sw widget + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + notebookAppendPage nb sw labelString) + (zip (map fst pairList) widgets) + listStore <- listStoreNew (map fst pairList) + listView <- treeViewNewWithModel listStore + widgetSetSizeRequest listView 100 (-1) + sel <- treeViewGetSelection listView + treeSelectionSetMode sel SelectionSingle + renderer <- cellRendererTextNew + col <- treeViewColumnNew + treeViewAppendColumn listView col + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer listStore $ \row -> + [ cellText := row ] + treeViewSetHeadersVisible listView False + treeSelectionSelectPath sel [0] + notebookSetCurrentPage nb 0 + sel `onSelectionChanged` (do + selections <- treeSelectionGetSelectedRows sel + case selections of + [[i]] -> notebookSetCurrentPage nb i + _ -> return ()) + + hb <- hBoxNew False 0 + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw listView + scrolledWindowSetPolicy sw PolicyNever PolicyAutomatic + boxPackStart hb sw PackNatural 0 + boxPackEnd hb nb PackGrow 7 + let newInj = (\v -> mapM_ (\ setInj -> setInj v) setInjs) + let newExt = (\v -> extract v getExts) + mapM_ (propagateEvent notifier notifiers) allGUIEvents + return (castToWidget hb, newInj, newExt, notifier) + +buildBoxEditor :: [FieldDescription alpha] -> Direction -> alpha + -> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier) +buildBoxEditor descrs dir v = do + resList <- mapM (\d -> buildEditor d v) descrs + notifier <- emptyNotifier + let (widgets, setInjs, getExts, notifiers) = unzip4 resList + hb <- case dir of + Horizontal -> do + b <- hBoxNew False 0 + return (castToBox b) + Vertical -> do + b <- vBoxNew False 0 + return (castToBox b) + let newInj = (\v -> mapM_ (\ setInj -> setInj v) setInjs) + let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of + Just s -> s + Nothing -> "Unnamed") descrs + let packParas = map (\fd -> getParameter paraPack (parameters fd)) descrs + let newExt = (\v -> extractAndValidate v getExts fieldNames) + mapM_ (\ (w,p) -> boxPackStart hb w p 0) $ zip widgets packParas + mapM_ (propagateEvent notifier notifiers) allGUIEvents + return (castToWidget hb, newInj, newExt, notifier) + + +flattenFieldDescription :: FieldDescription alpha -> [FieldDescription alpha] +flattenFieldDescription (VFD paras descrs) = concatMap flattenFieldDescription descrs +flattenFieldDescription (HFD paras descrs) = concatMap flattenFieldDescription descrs +flattenFieldDescription (NFD descrp) = concatMap (flattenFieldDescription.snd) descrp +flattenFieldDescription fd = [fd] + +-- ------------------------------------------------------------ +-- * Implementation of editing +-- ------------------------------------------------------------ + +-- +-- | Function to construct a field description +-- +mkField :: Eq beta => MkFieldDescription alpha beta +mkField parameters getter setter editor = + FD parameters + (\ dat -> do + noti <- emptyNotifier + (widget,inj,ext) <- editor parameters noti + let pext = (\a -> do + b <- ext + case b of + Just b -> return (Just (setter b a)) + Nothing -> return Nothing) + registerEvent noti FocusOut (Left (\e -> do + let name = eventPaneName e + e2 <- ext + when (isNothing e2) $ do + md <- messageDialogNew Nothing [] MessageWarning ButtonsClose + $ "The field " ++ name ++ " has an invalid value " + dialogRun md + widgetDestroy md + return (e{gtkReturn=False}))) + inj (getter dat) + return (widget, + (\a -> inj (getter a)), + pext, + noti)) + +-- | Function to construct an editor +-- +mkEditor :: (Container -> Injector alpha) -> Extractor alpha -> Editor alpha +mkEditor injectorC extractor parameters notifier = do + let (xalign, yalign, xscale, yscale) = getParameter paraOuterAlignment parameters + outerAlig <- alignmentNew xalign yalign xscale yscale + let (paddingTop, paddingBottom, paddingLeft, paddingRight) = getParameter paraOuterPadding parameters + alignmentSetPadding outerAlig paddingTop paddingBottom paddingLeft paddingRight + frame <- frameNew + frameSetShadowType frame (getParameter paraShadow parameters) + case getParameter paraName parameters of + "" -> return () + str -> if getParameter paraShowLabel parameters + then frameSetLabel frame str + else return () + + containerAdd outerAlig frame + let (xalign, yalign, xscale, yscale) = getParameter paraInnerAlignment parameters + innerAlig <- alignmentNew xalign yalign xscale yscale + let (paddingTop, paddingBottom, paddingLeft, paddingRight) = getParameter paraInnerPadding parameters + alignmentSetPadding innerAlig paddingTop paddingBottom paddingLeft paddingRight + containerAdd frame innerAlig + let (x,y) = getParameter paraMinSize parameters + widgetSetSizeRequest outerAlig x y + let name = getParameter paraName parameters + widgetSetName outerAlig name + let build = injectorC (castToContainer innerAlig) + return (castToWidget outerAlig, build, extractor) + +-- | Convenience method to validate and extract fields +-- +extractAndValidate :: alpha -> [alpha -> Extractor alpha] -> [String] -> IO (Maybe alpha) +extractAndValidate val getExts fieldNames = do + (newVal,errors) <- foldM (\ (val,errs) (ext,fn) -> do + extVal <- ext val + case extVal of + Just nval -> return (nval,errs) + Nothing -> return (val, (' ' : fn) : errs)) + (val,[]) (zip getExts fieldNames) + if null errors + then return (Just newVal) + else do + md <- messageDialogNew Nothing [] MessageWarning ButtonsClose + $ "The following fields have invalid values." ++ concat (reverse errors) + dialogRun md + widgetDestroy md + return Nothing + +extract :: alpha -> [alpha -> Extractor alpha] -> IO (Maybe alpha) +extract val = + foldM (\ mbVal ext -> + case mbVal of + Nothing -> return Nothing + Just val -> ext val) + (Just val) + +-- | get through outerAlignment, frame, innerAlignment +getRealWidget :: Widget -> IO (Maybe Widget) +getRealWidget w = do + mbF <- binGetChild (castToBin w) + case mbF of + Nothing -> return Nothing + Just f -> do + mbIA <- binGetChild (castToBin f) + case mbIA of + Nothing -> return Nothing + Just iA -> binGetChild (castToBin iA) + + + + diff --git a/src/Graphics/UI/Editor/Parameters.hs b/src/Graphics/UI/Editor/Parameters.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Editor/Parameters.hs @@ -0,0 +1,184 @@ +----------------------------------------------------------------------------- +-- +-- Module : Graphics.UI.Editor.Parameters +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : +-- Stability : provisional +-- Portability : portable +-- +-- | Module for parameters for editors +-- +----------------------------------------------------------------------------------- + +module Graphics.UI.Editor.Parameters ( + Parameters +, Parameter(..) +, paraName +, paraSynopsis +, paraDirection +, paraShowLabel +, paraShadow +, paraOuterAlignment +, paraInnerAlignment +, paraOuterPadding +, paraInnerPadding +, paraMinSize +, paraHorizontal +, paraStockId +, paraMultiSel +, paraPack + +, getParameter +, getParameterPrim +, (<<<-) +, emptyParams +, Direction(..) +, HorizontalAlign(..) +) where + +import Graphics.UI.Gtk +import Data.Maybe +import qualified Data.List as List + + +-- +-- | The direction of a split +-- +data Direction = Horizontal | Vertical + deriving (Eq,Show) + +data HorizontalAlign = StartHorizontal | StopHorizontal | Keep + deriving (Eq,Show) +-- +-- | A type for parameters for editors +-- +type Parameters = [Parameter] + +data Parameter = ParaName String + | ParaSynopsis String + | ParaDirection Direction + | ParaShadow ShadowType + | ParaShowLabel Bool + | ParaOuterAlignment (Float,Float,Float,Float) + -- | xalign yalign xscale yscale + | ParaOuterPadding (Int,Int,Int,Int) + -- | paddingTop paddingBottom paddingLeft paddingRight + | ParaInnerAlignment (Float,Float,Float,Float) + -- | xalign yalign xscale yscale + | ParaInnerPadding (Int,Int,Int,Int) + -- | paddingTop paddingBottom paddingLeft paddingRight + | ParaMinSize (Int, Int) + | ParaHorizontal HorizontalAlign + | ParaStockId String + | ParaMultiSel Bool + | ParaPack Packing + deriving (Eq,Show) + + +{-- #if MIN_VERSION_gtk(0,9,13) + -- now defined in gtk + #else + instance Show ShadowType + where show _ = "Any Shadow" + #endif +--} + +emptyParams :: [Parameter] +emptyParams = [] + +paraName :: (Parameter -> (Maybe String)) +paraName (ParaName str) = Just str +paraName _ = Nothing + +paraSynopsis :: (Parameter -> (Maybe String)) +paraSynopsis (ParaSynopsis str) = Just str +paraSynopsis _ = Nothing + +paraShowLabel :: (Parameter -> (Maybe Bool)) +paraShowLabel (ParaShowLabel b) = Just b +paraShowLabel _ = Nothing + +paraDirection :: (Parameter -> (Maybe Direction)) +paraDirection (ParaDirection d) = Just d +paraDirection _ = Nothing + +paraShadow :: (Parameter -> (Maybe ShadowType)) +paraShadow (ParaShadow d) = Just d +paraShadow _ = Nothing + +paraOuterAlignment :: (Parameter -> (Maybe (Float,Float,Float,Float))) +paraOuterAlignment (ParaOuterAlignment d) = Just d +paraOuterAlignment _ = Nothing + +paraInnerAlignment :: (Parameter -> (Maybe (Float,Float,Float,Float))) +paraInnerAlignment (ParaInnerAlignment d) = Just d +paraInnerAlignment _ = Nothing + +paraOuterPadding :: (Parameter -> (Maybe (Int,Int,Int,Int))) +paraOuterPadding (ParaOuterPadding d) = Just d +paraOuterPadding _ = Nothing + +paraInnerPadding :: (Parameter -> (Maybe (Int,Int,Int,Int))) +paraInnerPadding (ParaInnerPadding d) = Just d +paraInnerPadding _ = Nothing + +paraMinSize :: (Parameter -> (Maybe (Int, Int))) +paraMinSize (ParaMinSize d) = Just d +paraMinSize _ = Nothing + +paraHorizontal :: (Parameter -> (Maybe (HorizontalAlign))) +paraHorizontal (ParaHorizontal d) = Just d +paraHorizontal _ = Nothing + +paraStockId :: (Parameter -> (Maybe String)) +paraStockId (ParaStockId str) = Just str +paraStockId _ = Nothing + +paraMultiSel :: (Parameter -> (Maybe Bool)) +paraMultiSel (ParaMultiSel b) = Just b +paraMultiSel _ = Nothing + +paraPack :: (Parameter -> (Maybe Packing)) +paraPack (ParaPack b) = Just b +paraPack _ = Nothing + +-- +-- | Convenience method to get a parameter, or if not set the default parameter +-- +getParameter :: (Parameter -> (Maybe beta)) -> Parameters -> beta +getParameter selector parameter = + case getParameterPrim selector parameter of + Just ele -> ele + _ -> case getParameterPrim selector defaultParameters of + Just ele -> ele + _ -> error "default parameter not defined" + +getParameterPrim :: (Parameter -> (Maybe beta)) -> Parameters -> Maybe beta +getParameterPrim selector parameter = + case filter isJust $ map selector parameter of + (Just ele) : _ -> Just ele + _ -> Nothing + +(<<<-) :: (Parameter -> (Maybe beta)) -> Parameter -> Parameters -> Parameters +(<<<-) selector para params = para : filter (isNothing . selector) params + +defaultParameters :: Parameters +defaultParameters = + [ ParaName "" + , ParaStockId "" + , ParaSynopsis "" + , ParaDirection Horizontal + , ParaShadow ShadowNone + , ParaOuterAlignment (0.4, 0.5, 1.0, 0.7) + , ParaOuterPadding (5, 5, 5, 5) + , ParaInnerAlignment (0.4, 0.5, 1.0, 0.7) + , ParaInnerPadding (5, 5, 5, 5) + , ParaMinSize (-1,-1) + , ParaHorizontal Keep + , ParaMultiSel True + , ParaPack PackNatural + , ParaShowLabel True + ] + diff --git a/src/Graphics/UI/Editor/Simple.hs b/src/Graphics/UI/Editor/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Editor/Simple.hs @@ -0,0 +1,783 @@ +{-# OPTIONS_GHC -XScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Module : Graphics.UI.Editor.Simple +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : +-- Stability : provisional +-- Portability : portable +-- +-- | Module for making simple editors +-- +----------------------------------------------------------------------------------- + +module Graphics.UI.Editor.Simple ( + noEditor +, boolEditor +, boolEditor2 +, enumEditor +, clickEditor +, stringEditor +, multilineStringEditor +, intEditor +, genericEditor +, fontEditor +, colorEditor +, comboSelectionEditor +, staticListEditor +, staticListMultiEditor +, multiselectionEditor +, fileEditor +, otherEditor +, imageEditor + +, okCancelFields +) where + +import Graphics.UI.Gtk +import qualified Graphics.UI.Gtk as Gtk +import Control.Monad +import Data.IORef +import Data.List +import Data.Maybe +import System.FilePath.Posix + +import Graphics.UI.Editor.Parameters +import Graphics.UI.Editor.Basics +import Graphics.UI.Editor.MakeEditor +import Control.Event +import Graphics.UI.Gtk.Gdk.Events (Event(..)) +import MyMissing (allOf) + +-- ------------------------------------------------------------ +-- * Simple Editors +-- ------------------------------------------------------------ + +instance ContainerClass Widget +instance BinClass Widget +instance ButtonClass Widget + +-- +-- | An invisible editor without any effect +-- +noEditor :: alpha -> Editor alpha +noEditor proto parameters notifier = + mkEditor + (\ widget _ -> return ()) + (return (Just proto)) + parameters + notifier + +-- +-- | Editor for a boolean value in the form of a check button +-- +boolEditor :: Editor Bool +boolEditor parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget bool -> do + core <- readIORef coreRef + case core of + Nothing -> do + button <- checkButtonNewWithLabel (getParameter paraName parameters) + widgetSetName button (getParameter paraName parameters) + containerAdd widget button + toggleButtonSetActive button bool + mapM_ (activateEvent (castToWidget button) notifier Nothing) + [Clicked,FocusOut,FocusIn] + writeIORef coreRef (Just button) + Just button -> toggleButtonSetActive button bool) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just button -> do + r <- toggleButtonGetActive button + return (Just r)) + (paraName <<<- ParaName "" $ parameters) + notifier + +-- +-- | Editor for a boolean value in the form of two radio buttons +---- +boolEditor2 :: String -> Editor Bool +boolEditor2 label2 parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget bool -> do + core <- readIORef coreRef + case core of + Nothing -> do + box <- vBoxNew True 2 + radio1 <- radioButtonNewWithLabel (getParameter paraName parameters) + radio2 <- radioButtonNewWithLabelFromWidget radio1 label2 + boxPackStart box radio1 PackGrow 2 + boxPackStart box radio2 PackGrow 2 + widgetSetName radio1 $ getParameter paraName parameters ++ ".1" + widgetSetName radio2 $ getParameter paraName parameters ++ ".2" + containerAdd widget box + if bool + then toggleButtonSetActive radio1 True + else toggleButtonSetActive radio2 True + mapM_ (activateEvent (castToWidget radio1) notifier Nothing) + [Clicked,FocusOut,FocusIn] + mapM_ (activateEvent (castToWidget radio2) notifier Nothing) + [Clicked,FocusOut,FocusIn] + writeIORef coreRef (Just (radio1,radio2)) + Just (radio1,radio2) -> + if bool + then toggleButtonSetActive radio1 True + else toggleButtonSetActive radio2 True) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just (radio1,radio2) -> do + r <- toggleButtonGetActive radio1 + return (Just r)) + (paraName <<<- ParaName "" $ parameters) + notifier + +-- +-- | Editor for an enum value in the form of n radio buttons +---- +enumEditor :: forall alpha . (Show alpha, Enum alpha, Bounded alpha) => [String] -> Editor alpha +enumEditor labels parameters notifier = do + coreRef <- newIORef Nothing + let vals :: [alpha] = allOf + mkEditor + (\widget enumValue -> do + core <- readIORef coreRef + case core of + Nothing -> do + box <- vBoxNew True 2 + let label0 = if length labels > 0 then labels !! 0 else show (vals !! 0) + button0 <- radioButtonNewWithLabel label0 + buttons <- mapM (\ v -> do + let n = fromEnum v + let label = if length labels > n then labels !! n else show v + radio <- if n == 0 + then return button0 + else radioButtonNewWithLabelFromWidget button0 label + boxPackStart box radio PackGrow 2 + widgetSetName radio (label ++ show n) + return radio) vals + containerAdd widget box + mapM_ + (\e -> + (mapM_ + (\b -> activateEvent (castToWidget b) notifier Nothing e) + buttons)) + [Clicked,FocusOut,FocusIn] + mapM_ (\(b,n) -> toggleButtonSetActive b (n == fromEnum enumValue)) + (zip buttons [0..length buttons - 1]) + writeIORef coreRef (Just buttons) + Just buttons -> do + mapM_ (\(b,n) -> toggleButtonSetActive b (n == fromEnum enumValue)) + (zip buttons [0..length buttons - 1])) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just buttons -> do + boolArray <- mapM toggleButtonGetActive buttons + let mbInd = findIndex (== True) boolArray + let res = case mbInd of + Nothing -> Nothing + Just i -> Just (vals !! i) + return res) + (paraName <<<- ParaName "" $ parameters) + notifier + +-- | An Editor for nothing (which may report a click) in the form of a button +-- +clickEditor :: Editor () +clickEditor parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget bool -> do + core <- readIORef coreRef + case core of + Nothing -> do + button <- case getParameter paraStockId parameters of + "" -> buttonNewWithLabel (getParameter paraName parameters) + st -> buttonNewFromStock st + widgetSetName button (getParameter paraName parameters) + containerAdd widget button + activateEvent (castToWidget button) notifier Nothing Clicked + writeIORef coreRef (Just button) + Just button -> return ()) + (return (Just ())) + (paraName <<<- ParaName "" $ parameters) + notifier + +-- | An Editor to display an image +-- +imageEditor :: Editor StockId +imageEditor parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget stockId -> do + core <- readIORef coreRef + case core of + Nothing -> do + image <- imageNewFromStock stockId IconSizeLargeToolbar + widgetSetName image (getParameter paraName parameters) + containerAdd widget image + writeIORef coreRef (Just (image,stockId)) + Just (image,stockId2) -> imageSetFromStock image stockId IconSizeLargeToolbar) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just (_,stockId3) -> return (Just stockId3)) + parameters + notifier + +-- +-- | Editor for a string in the form of a text entry +-- +stringEditor :: (String -> Bool) -> Editor String +stringEditor validation parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget string -> do + core <- readIORef coreRef + case core of + Nothing -> do + entry <- entryNew + widgetSetName entry (getParameter paraName parameters) + mapM_ (activateEvent (castToWidget entry) notifier Nothing) + [FocusOut,FocusIn,AfterKeyRelease] + containerAdd widget entry + entrySetText entry string + writeIORef coreRef (Just entry) + Just entry -> entrySetText entry string) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just entry -> do + r <- entryGetText entry + if validation r + then return (Just r) + else return Nothing) + parameters + notifier + +-- +-- | Editor for a multiline string in the form of a multiline text entry +-- +multilineStringEditor :: Editor String +multilineStringEditor parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget string -> do + core <- readIORef coreRef + case core of + Nothing -> do + aTextView <- textViewNew + widgetSetName aTextView (getParameter paraName parameters) + aScrolledWindow <- scrolledWindowNew Nothing Nothing + scrolledWindowSetPolicy aScrolledWindow PolicyAutomatic PolicyAutomatic + containerAdd aScrolledWindow aTextView + containerAdd widget aScrolledWindow + mapM_ (activateEvent (castToWidget aTextView) notifier Nothing) + [ButtonRelease,FocusOut,FocusIn] + buffer <- textViewGetBuffer aTextView + textBufferSetText buffer string + writeIORef coreRef (Just (aScrolledWindow,aTextView)) + Just (aScrolledWindow,aTextView) -> do + buffer <- textViewGetBuffer aTextView + textBufferSetText buffer string) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just (aScrolledWindow, aTextView) -> do + buffer <- textViewGetBuffer aTextView + start <- textBufferGetStartIter buffer + end <- textBufferGetEndIter buffer + r <- textBufferGetText buffer start end False + return (Just r)) + parameters + notifier + +-- +-- | Editor for an integer in the form of a spin entry +-- +intEditor :: (Double,Double,Double) -> Editor Int +intEditor (min, max, step) parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget v -> do + core <- readIORef coreRef + case core of + Nothing -> do + spin <- spinButtonNewWithRange min max step + widgetSetName spin (getParameter paraName parameters) + mapM_ (activateEvent (castToWidget spin) notifier Nothing) + [FocusOut,FocusIn] + containerAdd widget spin + spinButtonSetValue spin (fromIntegral v) + writeIORef coreRef (Just spin) + Just spin -> spinButtonSetValue spin (fromIntegral v)) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just spin -> do + newNum <- spinButtonGetValue spin + return (Just (truncate newNum))) + parameters + notifier + +-- +-- | Editor for for any value which is an instance of Read and Show in the form of a +-- | text entry +genericEditor :: (Show beta, Read beta) => Editor beta +genericEditor parameters notifier = do + (wid,inj,ext) <- stringEditor (const True) parameters notifier + let ginj = inj . show + let gext = do + s <- ext + case s of + Nothing -> return Nothing + Just s -> catch (liftM Just (readIO s)) + (\e -> do + putStrLn ("Generic editor no parse for " ++ s ++ " " ++ show e) + return Nothing) + return (wid,ginj,gext) + +-- +-- | Editor for no value, it only emtis a clicked event and has the form of a check button +-- +buttonEditor :: Editor () +buttonEditor parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget _ -> do + core <- readIORef coreRef + case core of + Nothing -> do + button <- buttonNewWithLabel (getParameter paraName parameters) + widgetSetName button (getParameter paraName parameters) + containerAdd widget button + mapM_ (activateEvent (castToWidget button) notifier Nothing) + [Clicked,FocusIn] + writeIORef coreRef (Just button) + Just button -> return ()) + (return (Just ())) + parameters + notifier + +-- +-- | Editor for the selection of some element from a static list of elements in the +-- | form of a combo box + +comboSelectionEditor :: Eq beta => [beta] -> (beta -> String) -> Editor beta +comboSelectionEditor list showF parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget obj -> do + core <- readIORef coreRef + case core of + Nothing -> do + combo <- comboBoxNewText + mapM_ (\o -> comboBoxAppendText combo (showF o)) list + widgetSetName combo (getParameter paraName parameters) + mapM_ (activateEvent (castToWidget combo) notifier Nothing) + [FocusOut,FocusIn] + comboBoxSetActive combo 1 + containerAdd widget combo + let ind = elemIndex obj list + case ind of + Just i -> comboBoxSetActive combo i + Nothing -> return () + writeIORef coreRef (Just combo) + Just combo -> do + let ind = elemIndex obj list + case ind of + Just i -> comboBoxSetActive combo i + Nothing -> return ()) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just combo -> do + ind <- comboBoxGetActive combo + case ind of + (-1) -> return Nothing + otherwise -> return (Just (list !! ind))) + parameters + notifier + +-- +-- | Editor for the selection of some elements from a list of elements in the +-- | form of a list box +multiselectionEditor :: (Show beta, Eq beta) => Editor [beta] +multiselectionEditor parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget objs -> do + core <- readIORef coreRef + case core of + Nothing -> do + listStore <- listStoreNew ([]:: [alpha]) + listView <- treeViewNewWithModel listStore + widgetSetName listView (getParameter paraName parameters) + mapM_ (activateEvent (castToWidget listView) notifier Nothing) + [FocusOut,FocusIn] + sel <- treeViewGetSelection listView + treeSelectionSetMode sel SelectionMultiple + renderer <- cellRendererTextNew + col <- treeViewColumnNew + treeViewAppendColumn listView col + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer listStore + $ \row -> [ cellText := show row ] + treeViewSetHeadersVisible listView False + listStoreClear listStore + mapM_ (listStoreAppend listStore) objs + containerAdd widget listView + treeSelectionUnselectAll sel + --let inds = catMaybes $map (\obj -> elemIndex obj list) objs + --mapM_ (\i -> treeSelectionSelectPath sel [i]) inds + writeIORef coreRef (Just (listView,listStore)) + Just (listView,listStore) -> do + listStoreClear listStore + mapM_ (listStoreAppend listStore) objs) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just (listView,listStore) -> do + sel <- treeViewGetSelection listView + treePath <- treeSelectionGetSelectedRows sel + values <- mapM (\[i] -> listStoreGetValue listStore i) treePath + return (Just values)) + parameters + notifier + +-- +-- | Editor for the selection of some elements from a static list of elements in the +-- | form of a list box with toggle elements + +staticListMultiEditor :: (Eq beta) => [beta] -> (beta -> String) -> Editor [beta] +staticListMultiEditor list showF parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget objs -> do + core <- readIORef coreRef + case core of + Nothing -> do + listStore <- listStoreNew ([]:: [(Bool,beta)]) + listView <- treeViewNewWithModel listStore + widgetSetName listView (getParameter paraName parameters) + mapM_ (activateEvent (castToWidget listView) notifier Nothing) + [FocusOut,FocusIn] + sel <- treeViewGetSelection listView + treeSelectionSetMode sel SelectionSingle + rendererToggle <- cellRendererToggleNew + set rendererToggle [cellToggleActivatable := True] + rendererText <- cellRendererTextNew + col1 <- treeViewColumnNew + treeViewAppendColumn listView col1 + cellLayoutPackStart col1 rendererToggle True + cellLayoutSetAttributes col1 rendererToggle listStore + $ \row -> [ cellToggleActive := fst row] + col2 <- treeViewColumnNew + treeViewAppendColumn listView col2 + cellLayoutPackStart col2 rendererText True + cellLayoutSetAttributes col2 rendererText listStore + $ \row -> [ cellText := showF (snd row)] + treeViewSetHeadersVisible listView False + listStoreClear listStore + mapM_ (listStoreAppend listStore) $ map (\e -> (elem e objs,e)) list + let minSize = getParameter paraMinSize parameters + uncurry (widgetSetSizeRequest listView) minSize + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw listView + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + containerAdd widget sw + -- update the model when the toggle buttons are activated + on rendererToggle cellToggled $ \pathStr -> do + let (i:_) = stringToTreePath pathStr + val <- listStoreGetValue listStore i + listStoreSetValue listStore i (not (fst val),snd val) + listView `onKeyPress` (\event -> do + let Key { eventKeyName = name, eventModifier = modifier, eventKeyChar = char } = event + case (name, modifier, char) of + ("Return", _, _) -> do + sel <- treeViewGetSelection listView + rows <- treeSelectionGetSelectedRows sel + mapM_ (\ (i:_) -> do + val <- listStoreGetValue listStore i + listStoreSetValue listStore i (not (fst val),snd val)) rows + return True + _ -> return False) + writeIORef coreRef (Just (listView,listStore)) + Just (listView,listStore) -> do + let model = map (\e -> (elem e objs,e)) list + listStoreClear listStore + mapM_ (listStoreAppend listStore) $ map (\e -> (elem e objs,e)) list) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just (listView,listStore) -> do + model <- listStoreToList listStore + return (Just (map snd $ filter (\e -> fst e) model))) + parameters + notifier + +-- +-- | Editor for the selection of some elements from a static list of elements in the +-- | form of a list box + +staticListEditor :: (Eq beta) => [beta] -> (beta -> String) -> Editor beta +staticListEditor list showF parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget obj -> do + core <- readIORef coreRef + case core of + Nothing -> do + listStore <- listStoreNew ([]:: [alpha]) + listView <- treeViewNewWithModel listStore + widgetSetName listView (getParameter paraName parameters) + mapM_ (activateEvent (castToWidget listView) notifier Nothing) + [FocusOut,FocusIn] + sel <- treeViewGetSelection listView + treeSelectionSetMode sel + (case getParameter paraMultiSel parameters of + True -> SelectionMultiple + False -> SelectionSingle) + renderer <- cellRendererTextNew + col <- treeViewColumnNew + treeViewAppendColumn listView col + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer listStore + $ \row -> [ cellText := showF row ] + treeViewSetHeadersVisible listView False + listStoreClear listStore + mapM_ (listStoreAppend listStore) list + let minSize = getParameter paraMinSize parameters + uncurry (widgetSetSizeRequest listView) minSize + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw listView + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + containerAdd widget sw + treeSelectionUnselectAll sel + let mbInd = elemIndex obj list + case mbInd of + Nothing -> return () + Just ind -> treeSelectionSelectPath sel [ind] + writeIORef coreRef (Just listView) + Just listView -> do + sel <- treeViewGetSelection listView + treeSelectionUnselectAll sel + let mbInd = elemIndex obj list + case mbInd of + Nothing -> return () + Just ind -> treeSelectionSelectPath sel [ind]) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just listView -> do + sel <- treeViewGetSelection listView + treePaths <- treeSelectionGetSelectedRows sel + case treePaths of + [[i]] -> return (Just (list !! i)) + _ -> return Nothing) + parameters + notifier + + +-- +-- | Editor for the selection of a file path in the form of a text entry and a button, +-- | which opens a gtk file chooser +fileEditor :: Maybe FilePath -> FileChooserAction -> String -> Editor FilePath +fileEditor mbFilePath action buttonName parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget filePath -> do + core <- readIORef coreRef + case core of + Nothing -> do + button <- buttonNewWithLabel buttonName + widgetSetName button $ getParameter paraName parameters ++ "-button" + mapM_ (activateEvent (castToWidget button) notifier Nothing) + [FocusOut,FocusIn,Clicked] + entry <- entryNew + widgetSetName entry $ getParameter paraName parameters ++ "-entry" + -- set entry [ entryEditable := False ] + mapM_ (activateEvent (castToWidget entry) notifier Nothing) + [FocusOut,FocusIn] + registerEvent notifier Clicked (Left (buttonHandler entry)) + box <- case getParameter paraDirection parameters of + Horizontal -> do + r <- hBoxNew False 1 + return (castToBox r) + Vertical -> do + r <- vBoxNew False 1 + return (castToBox r) + boxPackStart box entry PackGrow 0 + boxPackEnd box button PackNatural 0 + containerAdd widget box + entrySetText entry filePath + writeIORef coreRef (Just entry) + Just entry -> entrySetText entry filePath) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just entry -> do + str <- entryGetText entry + return (Just str)) + parameters + notifier + where + buttonHandler entry e = do + mbFileName <- do + dialog <- fileChooserDialogNew + (Just "Select File") + Nothing + action + [("gtk-cancel" + ,ResponseCancel) + ,("gtk-open" + ,ResponseAccept)] + widgetShow dialog + response <- dialogRun dialog + case response of + ResponseAccept -> do + f <- fileChooserGetFilename dialog + widgetDestroy dialog + return f + ResponseCancel -> do + widgetDestroy dialog + return Nothing + ResponseDeleteEvent-> do + widgetDestroy dialog + return Nothing + _ -> return Nothing + case mbFileName of + Nothing -> return (e{gtkReturn=True}) + Just fn -> do + let relative = case mbFilePath of + Nothing -> fn + Just rel -> makeRelative rel fn + entrySetText entry relative +-- triggerEvent notifier SelectionChanged... + return (e{gtkReturn=True}) + +-- +-- | Editor for a font selection +-- +fontEditor :: Editor (Maybe String) +fontEditor parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget mbValue -> do + core <- readIORef coreRef + case core of + Nothing -> do + fs <- fontButtonNew + widgetSetName fs $ getParameter paraName parameters + mapM_ (activateEvent (castToWidget fs) notifier Nothing) + [FocusOut,FocusIn,Clicked] + containerAdd widget fs + case mbValue of + Nothing -> return True + Just s -> fontButtonSetFontName fs s + writeIORef coreRef (Just fs) + Just fs -> case mbValue of + Nothing -> return () + Just s -> do + fontButtonSetFontName fs s + return ()) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just fs -> do + f <- fontButtonGetFontName fs + return (Just (Just f))) + parameters + notifier + +-- +-- | Editor for color selection +-- +colorEditor :: Editor Color +colorEditor parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget c -> do + core <- readIORef coreRef + case core of + Nothing -> do + cs <- colorButtonNew + widgetSetName cs $ getParameter paraName parameters + mapM_ (activateEvent (castToWidget cs) notifier Nothing) + [FocusOut,FocusIn,Clicked] + containerAdd widget cs + colorButtonSetColor cs c + writeIORef coreRef (Just cs) + Just cs -> colorButtonSetColor cs c) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just cs -> do + c <- colorButtonGetColor cs + return (Just c)) + parameters + notifier + +-- +-- | An editor, which opens another editor +-- You have to inject a value before the button can be clicked. +-- +otherEditor :: (alpha -> String -> IO (Maybe alpha)) -> Editor alpha +otherEditor func parameters notifier = do + coreRef <- newIORef Nothing + mkEditor + (\widget val -> do + core <- readIORef coreRef + case core of + Nothing -> do + button <- buttonNewWithLabel (getParameter paraName parameters) + widgetSetName button $ getParameter paraName parameters + containerAdd widget button + mapM_ (activateEvent (castToWidget button) notifier Nothing) + [FocusOut,FocusIn,Clicked] + registerEvent notifier Clicked (Left (buttonHandler coreRef)) + writeIORef coreRef (Just (button,val)) + Just (button, oldval) -> writeIORef coreRef (Just (button, val))) + (do core <- readIORef coreRef + case core of + Nothing -> return Nothing + Just (_,val) -> return (Just val)) + (paraName <<<- ParaName "" $ parameters) + notifier + where + buttonHandler coreRef e = do + core <- readIORef coreRef + case core of + Nothing -> error "You have to inject a value before the button can be clicked" + Just (b,val) -> do + res <- func val (getParameter paraName parameters) + case res of + Nothing -> return (e{gtkReturn=True}) + Just nval -> do + writeIORef coreRef (Just (b, nval)) + return (e{gtkReturn=True}) + +okCancelFields :: FieldDescription () +okCancelFields = HFD emptyParams [ + mkField + (paraStockId <<<- ParaStockId stockOk + $ paraName <<<- ParaName "Ok" + $ emptyParams) + (const ()) + (\ a b -> b) + clickEditor + , mkField + (paraStockId <<<- ParaStockId stockCancel + $ paraName <<<- ParaName "Cancel" + $ emptyParams) + (const ()) + (\ _ b -> b) + clickEditor] + diff --git a/src/Graphics/UI/Frame/Panes.hs b/src/Graphics/UI/Frame/Panes.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Frame/Panes.hs @@ -0,0 +1,234 @@ +{-# OPTIONS_GHC + -XExistentialQuantification + -XMultiParamTypeClasses + -XFunctionalDependencies + -XNoMonomorphismRestriction -XCPP #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Core.Panes +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : +-- Stability : provisional21 +-- Portability : portable +-- +-- | The basic definitions for all panes +-- +------------------------------------------------------------------------------- + +module Graphics.UI.Frame.Panes ( + +-- * Panes and pane layout + PaneMonad(..) +, IDEPane(..) +, Pane(..) +, RecoverablePane(..) +, PaneDirection(..) +, PanePathElement(..) +, PanePath +, PaneLayout(..) +, PaneName +, Connection(..) +, Connections +, StandardPath +, FrameState(..) +, signalDisconnectAll +) where + +import Graphics.UI.Gtk hiding (get) +import System.Glib.GObject +import System.Glib.Signals +import Data.Maybe +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Typeable +import Control.Monad.Trans + +-- --------------------------------------------------------------------- +-- Panes and pane layout +-- + +-- +-- | A path to a pane +-- +type PanePath = [PanePathElement] + +-- +-- | An element of a path to a pane +-- +data PanePathElement = SplitP PaneDirection | GroupP String + deriving (Eq,Show,Read) + +-- +-- | The relative direction to a pane from the parent +-- +data PaneDirection = TopP | BottomP | LeftP | RightP + deriving (Eq,Show,Read) + +-- +-- | Description of a window layout +-- Horizontal: top bottom Vertical: left right +-- +data PaneLayout = HorizontalP PaneLayout PaneLayout Int + | VerticalP PaneLayout PaneLayout Int + | TerminalP { + paneGroups :: Map String PaneLayout + , paneTabs :: Maybe PaneDirection + , currentPage :: Int + , detachedId :: Maybe String + , detachedSize :: Maybe (Int, Int) } + deriving (Eq,Show,Read) + +-- +-- | All kinds of panes are instances of pane +-- + +class (Typeable alpha, PaneMonad delta) => Pane alpha delta | alpha -> delta where + + getTopWidget :: alpha -> Widget + -- ^ gets the top Widget of this pane + paneId :: alpha -> String + primPaneName :: alpha -> String + + paneName :: alpha -> PaneName + paneName b = if getAddedIndex b == 0 + then primPaneName b + else primPaneName b ++ "(" ++ show (getAddedIndex b) ++ ")" + + getAddedIndex :: alpha -> Int + getAddedIndex _ = 0 + + +class (Pane alpha delta, Typeable beta, Show beta, Read beta) => RecoverablePane alpha beta delta | beta -> alpha, alpha -> beta where + + saveState :: alpha -> delta (Maybe beta) + recoverState :: PanePath -> beta -> delta (Maybe alpha) + + builder :: PanePath -> Notebook -> Window -> delta (Maybe alpha,Connections) + + -- getEditor :: Editor alpha + + makeActive :: alpha -> delta () + makeActive pane = activateThisPane pane [] + + closePane :: alpha -> delta Bool + closePane = closeThisPane + + getPane :: delta (Maybe alpha) + getPane = getThisPane + + forceGetPane :: Either PanePath String -> delta alpha + forceGetPane pp = do mbPane <- getOrBuildPane pp + case mbPane of + Nothing -> error "Can't get pane " + Just p -> return p + + getOrBuildPane :: Either PanePath String -> delta (Maybe alpha) + getOrBuildPane = getOrBuildThisPane + + displayPane :: alpha -> Bool -> delta () + displayPane = displayThisPane + + getAndDisplayPane :: Either PanePath String -> Bool -> delta (Maybe alpha) + getAndDisplayPane pps b = do + mbP <- getOrBuildThisPane pps + case mbP of + Nothing -> return Nothing + Just p -> do + displayPane p b + return (Just p) + + buildPane :: PanePath -> + Notebook -> + (PanePath -> Notebook -> Window -> delta (Maybe alpha,Connections)) -> + delta (Maybe alpha) + buildPane = buildThisPane + + + +class MonadIO delta => PaneMonad delta where + setFrameState :: FrameState delta -> delta () + getFrameState :: delta (FrameState delta) + runInIO :: forall alpha beta. (beta -> delta alpha) -> delta (beta -> IO alpha) + panePathForGroup:: String -> delta PanePath + + getThisPane :: forall alpha beta . RecoverablePane alpha beta delta => delta (Maybe alpha) + displayThisPane :: forall alpha beta . RecoverablePane alpha beta delta => alpha -> Bool -> delta () + getOrBuildThisPane + :: forall alpha beta . RecoverablePane alpha beta delta => Either PanePath String -> delta (Maybe alpha) + buildThisPane :: forall alpha beta . RecoverablePane alpha beta delta => + PanePath -> + Notebook -> + (PanePath -> Notebook -> Window -> delta (Maybe alpha,Connections)) -> + delta (Maybe alpha) + activateThisPane :: forall alpha beta . RecoverablePane alpha beta delta => alpha -> Connections -> delta () + closeThisPane :: forall alpha beta . RecoverablePane alpha beta delta => alpha -> delta Bool + +type PaneName = String + +data IDEPane delta = forall alpha beta. (RecoverablePane alpha beta delta) => PaneC alpha + +instance Eq (IDEPane delta) where + (==) (PaneC x) (PaneC y) = paneName x == paneName y + +instance Ord (IDEPane delta) where + (<=) (PaneC x) (PaneC y) = paneName x <= paneName y + +instance Show (IDEPane delta) where + show (PaneC x) = "Pane " ++ paneName x + +type StandardPath = PanePath + +data FrameState delta = FrameState { + windows :: [Window] +, uiManager :: UIManager +, panes :: Map PaneName (IDEPane delta) +, paneMap :: (Map PaneName (PanePath, Connections)) +, activePane :: Maybe (PaneName, Connections) +, panePathFromNB :: ! (Map Notebook PanePath) +, layout :: PaneLayout} + deriving Show + +instance Show Window where + show _ = "a Window" + +instance Show UIManager where + show _ = "a UIManager" + +instance Show Connection where + show _ = "a Connection" + +instance Show Notebook where + show _ = "a Notebook" + +-- +-- | Signal handlers for the different pane types +-- +data Connection = forall alpha . GObjectClass alpha => ConnectC (ConnectId alpha) + +type Connections = [Connection] + +signalDisconnectAll :: Connections -> IO () +signalDisconnectAll = mapM_ (\ (ConnectC s) -> signalDisconnect s) + + +-- Necessary with pre 10.1 verion of gtk2hs + +#ifdef MIN_VERSION_gtk +#if MIN_VERSION_gtk(0,10,1) +#else +instance Eq Notebook + where (==) a b = let (GObject pa, GObject pb) = (toGObject a, toGObject b) + in pa == pb +instance Ord Notebook + where (<=) a b = let (GObject pa, GObject pb) = (toGObject a, toGObject b) + in pa <= pb +instance Eq Window + where (==) a b = let (GObject pa, GObject pb) = (toGObject a, toGObject b) + in pa == pb +instance Eq Widget + where (==) a b = let (GObject pa, GObject pb) = (toGObject a, toGObject b) + in pa == pb +#endif +#endif diff --git a/src/Graphics/UI/Frame/ViewFrame.hs b/src/Graphics/UI/Frame/ViewFrame.hs new file mode 100644 --- /dev/null +++ b/src/Graphics/UI/Frame/ViewFrame.hs @@ -0,0 +1,1393 @@ +{-# OPTIONS_GHC + -XFunctionalDependencies + -XNoMonomorphismRestriction + -XFlexibleInstances + -XMultiParamTypeClasses + -XUndecidableInstances + -XDeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Core.ViewFrame +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : +-- Stability : provisional +-- Portability : portable +-- +-- +-- | Splittable panes containing notebooks with any widgets +-- +--------------------------------------------------------------------------------- + + +module Graphics.UI.Frame.ViewFrame ( + removePaneAdmin +, addPaneAdmin +, notebookInsertOrdered +, markLabel + +-- * Convenience methods for accesing Pane state +, posTypeToPaneDirection +, paneDirectionToPosType +, paneFromName +, mbPaneFromName +, guiPropertiesFromName + +-- * View Actions +, viewMove +, viewSplitHorizontal +, viewSplitVertical +--, viewSplit +, viewSplit' +, viewNewGroup +, newGroupOrBringToFront +, bringGroupToFront +, viewNest +, viewNest' +, viewDetach +, viewDetach' +, handleNotebookSwitch +, viewCollapse +, viewCollapse' +, viewTabsPos +, viewSwitchTabs + +, closeGroup +, allGroupNames + +-- * View Queries +, getBestPanePath +, getBestPathForId +, getActivePanePath +, getActivePanePathOrStandard +, figureOutPaneName +, getNotebook +, getPaned +, getActiveNotebook +, getActivePane +, setActivePane +, getUiManager +, getWindows +, getMainWindow +, getLayout +, getPanesSt +, getPaneMapSt +, getPanePrim +, getPanes + +-- * View Actions +, bringPaneToFront +, newNotebook +, newNotebook' + +-- * Accessing GUI elements +--, widgetFromPath +, getUIAction +, widgetGet + +, initGtkRc +) where + +import Graphics.UI.Gtk hiding (afterToggleOverwrite,onToggleOverwrite) +import Control.Monad.Reader +import qualified Data.Map as Map +import Data.List +import Data.Maybe +import Data.Unique +import Data.Typeable + +import Graphics.UI.Frame.Panes +import Graphics.UI.Editor.Parameters +import System.Glib (GObjectClass(..), isA) +import Graphics.UI.Gtk.Types (gTypeNotebook) +import System.CPUTime (getCPUTime) +import Graphics.UI.Gtk.Gdk.Enums (Modifier(..)) +import MyMissing +import Graphics.UI.Gtk.Gdk.EventM (TimeStamp(..)) +import Graphics.UI.Editor.MakeEditor + (mkField, FieldDescription(..), buildEditor) +import Graphics.UI.Editor.Simple (stringEditor, okCancelFields) +import Control.Event (registerEvent) +import Graphics.UI.Editor.Basics + (eventPaneName, GUIEventSelector(..)) +import qualified Data.Set as Set (unions, member) +import Data.Set (Set(..)) +import Graphics.UI.Gtk.Gdk.Events (Event(..)) + +--import Debug.Trace (trace) +trace a b = b + +groupPrefix = "_group_" + +withoutGroupPrefix :: String -> String +withoutGroupPrefix s = case groupPrefix `stripPrefix` s of + Nothing -> s + Just s' -> s' + +initGtkRc :: IO () +initGtkRc = return () +{-- rcParseString ("style \"leksah-close-button-style\"\n" ++ + "{\n" ++ + " GtkWidget::focus-padding = 0\n" ++ + " GtkWidget::focus-line-width = 0\n" ++ + " xthickness = 0\n" ++ + " ythickness = 0\n" ++ + "}\n" ++ + "widget \"*.leksah-close-button\" style \"leksah-close-button-style\"") +--} + +removePaneAdmin :: RecoverablePane alpha beta delta => alpha -> delta () +removePaneAdmin pane = do + panes' <- getPanesSt + paneMap' <- getPaneMapSt + setPanesSt (Map.delete (paneName pane) panes') + setPaneMapSt (Map.delete (paneName pane) paneMap') + +addPaneAdmin :: RecoverablePane alpha beta delta => alpha -> Connections -> PanePath -> delta Bool +addPaneAdmin pane conn pp = do + panes' <- getPanesSt + paneMap' <- getPaneMapSt + liftIO $ widgetSetName (getTopWidget pane) (paneName pane) + let b1 = case Map.lookup (paneName pane) paneMap' of + Nothing -> True + Just it -> False + let b2 = case Map.lookup (paneName pane) panes' of + Nothing -> True + Just it -> False + if b1 && b2 + then do + setPaneMapSt (Map.insert (paneName pane) (pp, conn) paneMap') + setPanesSt (Map.insert (paneName pane) (PaneC pane) panes') + return True + else do + trace ("ViewFrame>addPaneAdmin:pane with this name already exist" ++ paneName pane) $ + return False + +getPanePrim :: RecoverablePane alpha beta delta => delta (Maybe alpha) +getPanePrim = do + selectedPanes <- getPanes + if null selectedPanes || length selectedPanes > 1 + then return Nothing + else (return (Just $ head selectedPanes)) + +getPanes :: RecoverablePane alpha beta delta => delta ([alpha]) +getPanes = do + panes' <- getPanesSt + return (catMaybes + $ map (\(PaneC p) -> cast p) + $ Map.elems panes') + +notebookInsertOrdered :: PaneMonad alpha => (NotebookClass self, WidgetClass child) + => self + -> child -- child - the Widget to use as the contents of the page. + -> String + -> Maybe Label -- the label for the page as String or Label + -> Bool + -> alpha () +notebookInsertOrdered nb widget labelStr mbLabel isGroup = do + label <- case mbLabel of + Nothing -> liftIO $ labelNew (Just labelStr) + Just l -> return l + menuLabel <- liftIO $ labelNew (Just labelStr) + numPages <- liftIO $ notebookGetNPages nb + mbWidgets <- liftIO $ mapM (notebookGetNthPage nb) [0 .. (numPages-1)] + let widgets = map (\v -> forceJust v "ViewFrame.notebookInsertOrdered: no widget") mbWidgets + labelStrs <- liftIO $ mapM widgetGetName widgets + let pos = case findIndex (\ s -> withoutGroupPrefix s > withoutGroupPrefix labelStr) labelStrs of + Just i -> i + Nothing -> -1 + labelBox <- if isGroup then groupLabel labelStr else mkLabelBox label labelStr + liftIO $ do + markLabel nb labelBox False + realPos <- notebookInsertPageMenu nb widget labelBox menuLabel pos + widgetShowAll labelBox + notebookSetCurrentPage nb realPos + +-- | Returns a label box +mkLabelBox :: PaneMonad alpha => Label -> String -> alpha EventBox +mkLabelBox lbl paneName = do + (tb,lb) <- liftIO $ do + miscSetAlignment (castToMisc lbl) 0.0 0.0 + miscSetPadding (castToMisc lbl) 0 0 + + labelBox <- eventBoxNew + eventBoxSetVisibleWindow labelBox False + innerBox <- hBoxNew False 0 + + tabButton <- buttonNew + widgetSetName tabButton "leksah-close-button" + buttonSetFocusOnClick tabButton False + buttonSetRelief tabButton ReliefNone + buttonSetAlignment tabButton (0.0,0.0) + + image <- imageNewFromStock stockClose IconSizeMenu + mbPB <- widgetRenderIcon tabButton stockClose IconSizeMenu "" + (height,width) <- case mbPB of + Nothing -> return (14,14) + Just pb -> do + h <- pixbufGetHeight pb + w <- pixbufGetWidth pb + return (h,w) + on tabButton styleSet (\style -> do + widgetSetSizeRequest tabButton (height + 2) (width + 2)) + containerSetBorderWidth tabButton 0 + containerAdd tabButton image + + boxPackStart innerBox lbl PackNatural 0 + boxPackEnd innerBox tabButton PackNatural 0 + + containerAdd labelBox innerBox + dragSourceSet labelBox [Button1] [ActionCopy,ActionMove] + tl <- targetListNew + targetListAddTextTargets tl 0 + dragSourceSetTargetList labelBox tl + on labelBox dragDataGet (\ cont id timeStamp -> do + selectionDataSetText paneName + return ()) + return (tabButton,labelBox) + cl <- runInIO closeHandler + liftIO $ onClicked tb (cl ()) + + return lb + where + closeHandler :: PaneMonad alpha => () -> alpha () + closeHandler _ = case groupPrefix `stripPrefix` paneName of + Just group -> do + closeGroup group + Nothing -> do + (PaneC pane) <- paneFromName paneName + closePane pane + return () + +groupLabel :: PaneMonad beta => String -> beta EventBox +groupLabel group = do + label <- liftIO $ labelNew Nothing + liftIO $ labelSetUseMarkup label True + liftIO $ labelSetMarkup label ("" ++ group ++ "") + labelBox <- mkLabelBox label (groupPrefix ++ group) + liftIO $ widgetShowAll labelBox + return labelBox + +-- | Add the change mark or removes it +markLabel :: (WidgetClass alpha, NotebookClass beta) => beta -> alpha -> Bool -> IO () +markLabel nb topWidget modified = do + mbBox <- notebookGetTabLabel nb topWidget + case mbBox of + Nothing -> return () + Just box -> do + mbContainer <- binGetChild (castToBin box) + case mbContainer of + Nothing -> return () + Just container -> do + children <- containerGetChildren container + let label = castToLabel $ forceHead children "ViewFrame>>markLabel: empty children" + text <- widgetGetName topWidget + labelSetUseMarkup (castToLabel label) True + labelSetMarkup (castToLabel label) + (if modified + then "" ++ text ++ "" + else text) + +-- | Constructs a unique pane name, which is an index and a string +figureOutPaneName :: PaneMonad alpha => String -> Int -> alpha (Int,String) +figureOutPaneName bn ind = do + bufs <- getPanesSt + let ind = foldr (\(PaneC buf) ind -> + if primPaneName buf == bn + then max ind ((getAddedIndex buf) + 1) + else ind) + 0 (Map.elems bufs) + if ind == 0 + then return (0,bn) + else return (ind,bn ++ "(" ++ show ind ++ ")") + +paneFromName :: PaneMonad alpha => PaneName -> alpha (IDEPane alpha) +paneFromName pn = do + mbPane <- mbPaneFromName pn + case mbPane of + Just p -> return p + Nothing -> error $ "ViewFrame>>paneFromName:Can't find pane from unique name " ++ pn + +mbPaneFromName :: PaneMonad alpha => PaneName -> alpha (Maybe (IDEPane alpha)) +mbPaneFromName pn = do + panes <- getPanesSt + return (Map.lookup pn panes) + +-- | +guiPropertiesFromName :: PaneMonad alpha => PaneName -> alpha (PanePath, Connections) +guiPropertiesFromName pn = do + paneMap <- getPaneMapSt + case Map.lookup pn paneMap of + Just it -> return it + otherwise -> error $"Cant't find guiProperties from unique name " ++ pn + +posTypeToPaneDirection PosLeft = LeftP +posTypeToPaneDirection PosRight = RightP +posTypeToPaneDirection PosTop = TopP +posTypeToPaneDirection PosBottom = BottomP + +paneDirectionToPosType LeftP = PosLeft +paneDirectionToPosType RightP = PosRight +paneDirectionToPosType TopP = PosTop +paneDirectionToPosType BottomP = PosBottom + +-- +-- | Toggle the tabs of the current notebook +-- +viewSwitchTabs :: PaneMonad alpha => alpha () +viewSwitchTabs = do + mbNb <- getActiveNotebook + case mbNb of + Nothing -> return () + Just nb -> liftIO $ do + b <- notebookGetShowTabs nb + notebookSetShowTabs nb (not b) + +-- +-- | Sets the tab position in the current notebook +-- +viewTabsPos :: PaneMonad alpha => PositionType -> alpha () +viewTabsPos pos = do + mbNb <- getActiveNotebook + case mbNb of + Nothing -> return () + Just nb -> liftIO $notebookSetTabPos nb pos + +-- +-- | Split the currently active pane in horizontal direction +-- +viewSplitHorizontal :: PaneMonad alpha => alpha () +viewSplitHorizontal = viewSplit Horizontal + +-- +-- | Split the currently active pane in vertical direction +-- +viewSplitVertical :: PaneMonad alpha => alpha () +viewSplitVertical = viewSplit Vertical + +-- +-- | The active view can be split in two (horizontal or vertical) +-- +viewSplit :: PaneMonad alpha => Direction -> alpha () +viewSplit dir = do + mbPanePath <- getActivePanePath + case mbPanePath of + Nothing -> return () + Just panePath -> do + viewSplit' panePath dir + +viewSplit' :: PaneMonad alpha => PanePath -> Direction -> alpha () +viewSplit' panePath dir = do + l <- getLayout + case layoutFromPath panePath l of + (TerminalP _ _ _ (Just _) _) -> trace ("ViewFrame>>viewSplit': can't split detached: ") return () + _ -> do + activeNotebook <- (getNotebook' "viewSplit") panePath + ind <- liftIO $ notebookGetCurrentPage activeNotebook + mbPD <- do + mbParent <- liftIO $ widgetGetParent activeNotebook + case mbParent of + Nothing -> trace ("ViewFrame>>viewSplit': parent not found: ") return Nothing + Just parent -> do + (nb,paneDir) <- do + let (name,altname,paneDir, + oldPath,newPath) = case dir of + Horizontal -> ("top", + "bottom", + TopP, + panePath ++ [SplitP TopP], + panePath ++ [SplitP BottomP]) + Vertical -> ("left", + "right", + LeftP, + panePath ++ [SplitP LeftP], + panePath ++ [SplitP RightP]) + adjustNotebooks panePath oldPath + frameState <- getFrameState + setPanePathFromNB $ Map.insert activeNotebook oldPath (panePathFromNB frameState) + nb <- newNotebook newPath + (np,nbi) <- liftIO $ do + newpane <- case dir of + Horizontal -> do h <- vPanedNew + return (castToPaned h) + Vertical -> do v <- hPanedNew + return (castToPaned v) + rName <- widgetGetName activeNotebook + widgetSetName newpane rName + widgetSetName nb altname + panedPack2 newpane nb True True + nbIndex <- if parent `isA` gTypeNotebook + then notebookPageNum ((castToNotebook' "viewSplit'1") parent) activeNotebook + else trace ("ViewFrame>>viewSplit': parent not a notebook: ") return Nothing + containerRemove (castToContainer parent) activeNotebook + widgetSetName activeNotebook name + panedPack1 newpane activeNotebook True True + return (newpane,nbIndex) + case (reverse panePath, nbi) of + (SplitP dir:_, _) + | dir `elem` [TopP, LeftP] -> liftIO $ panedPack1 (castToPaned parent) np True True + | otherwise -> liftIO $ panedPack2 (castToPaned parent) np True True + (GroupP group:_, Just n) -> do + liftIO $ notebookInsertPage ((castToNotebook' "viewSplit' 2") parent) np group n + label <- groupLabel group + liftIO $ notebookSetTabLabel ((castToNotebook' "viewSplit' 3") parent) np label + label2 <- groupMenuLabel group + liftIO $ notebookSetMenuLabel ((castToNotebook' "viewSplit' 4") parent) np label2 + return () + ([], _) -> do + liftIO $ boxPackStart (castToBox parent) np PackGrow 0 + liftIO $ boxReorderChild (castToVBox parent) np 2 + _ -> error "No notebook index found in viewSplit" + liftIO $ do + widgetShowAll np + widgetGrabFocus activeNotebook + case nbi of + Just n -> do + notebookSetCurrentPage ((castToNotebook' "viewSplit' 5") parent) n + return () + _ -> trace ("ViewFrame>>viewSplit': parent not a notebook2: ")return () + return (nb,paneDir) + handleFunc <- runInIO (handleNotebookSwitch nb) + liftIO $ afterSwitchPage nb handleFunc + return (Just (paneDir,dir)) + case mbPD of + Just (paneDir,pdir) -> do + adjustPanes panePath (panePath ++ [SplitP paneDir]) + adjustLayoutForSplit paneDir panePath + mbWidget <- liftIO $ notebookGetNthPage activeNotebook ind + when (isJust mbWidget) $ do + name <- liftIO $ widgetGetName (fromJust mbWidget) + mbPane <- mbPaneFromName name + case mbPane of + Just (PaneC pane) -> move (panePath ++ [SplitP (otherDirection paneDir)]) pane + Nothing -> return () + Nothing -> return () + +-- +-- | Two notebooks can be collapsed to one +-- +viewCollapse :: PaneMonad alpha => alpha () +viewCollapse = do + mbPanePath <- getActivePanePath + case mbPanePath of + Nothing -> return () + Just panePath -> do + viewCollapse' panePath + +viewCollapse' :: PaneMonad alpha => PanePath -> alpha () +viewCollapse' panePath = trace "viewCollapse' called" $ do + layout1 <- getLayoutSt + case layoutFromPath panePath layout1 of + (TerminalP _ _ _ (Just _) _) -> trace ("ViewFrame>>viewCollapse': can't collapse detached: ") + return () + _ -> do + let newPanePath = init panePath + let mbOtherSidePath = otherSide panePath + case mbOtherSidePath of + Nothing -> trace ("ViewFrame>>viewCollapse': no other side path found: ") return () + Just otherSidePath -> do + nbop <- getNotebookOrPaned otherSidePath castToWidget + let nb = if nbop `isA` gTypeNotebook + then Just ((castToNotebook' "viewCollapse' 0") nbop) + else Nothing + case nb of + Nothing -> trace ("ViewFrame>>viewCollapse': other side path not collapsedXX: ") $ + case layoutFromPath otherSidePath layout1 of + VerticalP _ _ _ -> do + viewCollapse' (otherSidePath ++ [SplitP LeftP]) + viewCollapse' panePath + HorizontalP _ _ _ -> do + viewCollapse' (otherSidePath ++ [SplitP TopP]) + viewCollapse' panePath + otherwise -> trace ("ViewFrame>>viewCollapse': impossible1 ") return () + Just otherSideNotebook -> do + paneMap <- getPaneMapSt + activeNotebook <- (getNotebook' "viewCollapse' 1") panePath + -- 1. Move panes and groups to one side (includes changes to paneMap and layout) + let paneNamesToMove = map (\(w,(p,_)) -> w) + $filter (\(w,(p,_)) -> otherSidePath == p) + $Map.toList paneMap + panesToMove <- mapM paneFromName paneNamesToMove + mapM_ (\(PaneC p) -> move panePath p) panesToMove + let groupNames = map (\n -> groupPrefix ++ n) $ + getGroupsFrom otherSidePath layout1 + mapM_ (\n -> move' (n,activeNotebook)) groupNames + -- 2. Remove unused notebook from admin + st <- getFrameState + let ! newMap = Map.delete otherSideNotebook (panePathFromNB st) + setPanePathFromNB newMap + -- 3. Remove one level and reparent notebook + mbParent <- liftIO $ widgetGetParent activeNotebook + case mbParent of + Nothing -> error "collapse: no parent" + Just parent -> do + mbGrandparent <- liftIO $ widgetGetParent parent + case mbGrandparent of + Nothing -> error "collapse: no grandparent" + Just grandparent -> do + nbIndex <- if grandparent `isA` gTypeNotebook + then liftIO $ notebookPageNum ((castToNotebook' "viewCollapse'' 1") grandparent) parent + else return Nothing + liftIO $ containerRemove (castToContainer grandparent) parent + liftIO $ containerRemove (castToContainer parent) activeNotebook + if length panePath > 1 + then do + let lasPathElem = last newPanePath + case (lasPathElem, nbIndex) of + (SplitP dir, _) | dir == TopP || dir == LeftP -> + liftIO $ panedPack1 (castToPaned grandparent) activeNotebook True True + (SplitP dir, _) | dir == BottomP || dir == RightP -> + liftIO $ panedPack2 (castToPaned grandparent) activeNotebook True True + (GroupP group, Just n) -> do + liftIO $ notebookInsertPage ((castToNotebook' "viewCollapse'' 2") grandparent) activeNotebook group n + label <- groupLabel group + liftIO $ do + notebookSetTabLabel ((castToNotebook' "viewCollapse'' 3") grandparent) activeNotebook label + notebookSetCurrentPage ((castToNotebook' "viewCollapse'' 4") grandparent) n + return () + _ -> error "collapse: Unable to find page index" + liftIO $ widgetSetName activeNotebook $panePathElementToWidgetName lasPathElem + else liftIO $ do + boxPackStart (castToVBox grandparent) activeNotebook PackGrow 0 + boxReorderChild (castToVBox grandparent) activeNotebook 2 + widgetSetName activeNotebook "root" + -- 4. Change panePathFromNotebook + adjustNotebooks panePath newPanePath + -- 5. Change paneMap + adjustPanes panePath newPanePath + -- 6. Change layout + adjustLayoutForCollapse panePath + +getGroupsFrom :: PanePath -> PaneLayout -> [String] +getGroupsFrom path layout = + case layoutFromPath path layout of + t@(TerminalP _ _ _ _ _) -> Map.keys (paneGroups t) + HorizontalP _ _ _ -> [] + VerticalP _ _ _ -> [] + +viewNewGroup :: PaneMonad alpha => alpha () +viewNewGroup = do + mainWindow <- getMainWindow + mbGroupName <- liftIO $ groupNameDialog mainWindow + case + mbGroupName of + Just groupName -> do + layout <- getLayoutSt + if groupName `Set.member` allGroupNames layout + then liftIO $ do + md <- messageDialogNew (Just mainWindow) [] MessageWarning ButtonsClose + ("Group name not unique " ++ groupName) + dialogRun md + widgetDestroy md + return () + else viewNest groupName + Nothing -> return () + +newGroupOrBringToFront :: PaneMonad alpha => String -> PanePath -> alpha (Maybe PanePath,Bool) +newGroupOrBringToFront groupName pp = do + layout <- getLayoutSt + if groupName `Set.member` allGroupNames layout + then do + mbPP <- bringGroupToFront groupName + return (mbPP,False) + else let realPath = getBestPanePath pp layout in do + viewNest' realPath groupName + return (Just (realPath ++ [GroupP groupName]),True) + +bringGroupToFront :: PaneMonad alpha => String -> alpha (Maybe PanePath) +bringGroupToFront groupName = do + layout <- getLayoutSt + case findGroupPath groupName layout of + Just path -> do + widget <- getNotebookOrPaned path castToWidget + liftIO $ setCurrentNotebookPages widget + return (Just path) + Nothing -> return Nothing + + +-- Yet another stupid little dialog + +groupNameDialog :: Window -> IO (Maybe String) +groupNameDialog parent = liftIO $ do + dia <- dialogNew + windowSetTransientFor dia parent + windowSetTitle dia "Enter group name" + upper <- dialogGetUpper dia + lower <- dialogGetActionArea dia + (widget,inj,ext,_) <- buildEditor moduleFields "" + (widget2,_,_,notifier) <- buildEditor okCancelFields () + registerEvent notifier Clicked (Left (\e -> do + case eventPaneName e of + "Ok" -> dialogResponse dia ResponseOk + _ -> dialogResponse dia ResponseCancel + return e)) + boxPackStart upper widget PackGrow 7 + boxPackStart lower widget2 PackNatural 7 + widgetShowAll dia + resp <- dialogRun dia + value <- ext ("") + widgetDestroy dia + case resp of + ResponseOk | value /= Just "" -> return value + _ -> return Nothing + where + moduleFields :: FieldDescription String + moduleFields = VFD emptyParams [ + mkField + (paraName <<<- ParaName ("New group ") + $ emptyParams) + id + (\ a b -> a) + (stringEditor (\s -> True))] + +viewNest :: PaneMonad alpha => String -> alpha () +viewNest group = do + mbPanePath <- getActivePanePath + case mbPanePath of + Nothing -> return () + Just panePath -> do + viewNest' panePath group + +viewNest' :: PaneMonad alpha => PanePath -> String -> alpha () +viewNest' panePath group = do + activeNotebook <- (getNotebook' "viewNest' 1") panePath + mbParent <- liftIO $ widgetGetParent activeNotebook + case mbParent of + Nothing -> return () + Just parent -> do + layout <- getLayoutSt + let paneLayout = layoutFromPath panePath layout + case paneLayout of + (TerminalP {}) -> do + nb <- newNotebook (panePath ++ [GroupP group]) + liftIO $ widgetSetName nb (groupPrefix ++ group) + notebookInsertOrdered activeNotebook nb group Nothing True + liftIO $ widgetShowAll nb + --widgetGrabFocus activeNotebook + handleFunc <- runInIO (handleNotebookSwitch nb) + liftIO $ afterSwitchPage nb handleFunc + adjustLayoutForNest group panePath + _ -> return () + +closeGroup :: PaneMonad alpha => String -> alpha () +closeGroup groupName = do + layout <- getLayout + let mbPath = findGroupPath groupName layout + mainWindow <- getMainWindow + case mbPath of + Nothing -> trace ("ViewFrame>>closeGroup: Group path not found: " ++ groupName) return () + Just path -> do + panesMap <- getPaneMapSt + let nameAndpathList = filter (\(a,pp) -> path `isPrefixOf` pp) + $ map (\(a,b) -> (a,fst b)) (Map.assocs panesMap) + continue <- case nameAndpathList of + (_:_) -> liftIO $ do + md <- messageDialogNew (Just mainWindow) [] MessageQuestion ButtonsYesNo + ("Group " ++ groupName ++ " not empty. Close with all contents?") + rid <- dialogRun md + widgetDestroy md + case rid of + ResponseYes -> return True + otherwise -> return False + [] -> return True + when continue $ do + panes <- mapM paneFromName $ map fst nameAndpathList + results <- mapM (\ (PaneC p) -> closePane p) panes + when (foldr (&&) True results) $ do + nbOrPaned <- getNotebookOrPaned path castToWidget + mbParent <- liftIO $ widgetGetParent nbOrPaned + case mbParent of + Nothing -> error "ViewFrame>>closeGroup: closeGroup: no parent" + Just parent -> liftIO $ containerRemove (castToContainer parent) nbOrPaned + setLayoutSt (removeGL path layout) + ppMap <- getPanePathFromNB + setPanePathFromNB (Map.filter (\pa -> not (path `isPrefixOf` pa)) ppMap) + +viewDetach :: PaneMonad alpha => alpha (Maybe (Window,Widget)) +viewDetach = do + id <- liftIO $ fmap show getCPUTime + mbPanePath <- getActivePanePath + case mbPanePath of + Nothing -> return Nothing + Just panePath -> do + viewDetach' panePath id + +viewDetach' :: PaneMonad alpha => PanePath -> String -> alpha (Maybe (Window,Widget)) +viewDetach' panePath id = do + activeNotebook <- (getNotebook' "viewDetach'") panePath + mbParent <- liftIO $ widgetGetParent activeNotebook + case mbParent of + Nothing -> return Nothing + Just parent -> do + layout <- getLayoutSt + let paneLayout = layoutFromPath panePath layout + case paneLayout of + (TerminalP{detachedSize = size}) -> do + window <- liftIO $ do + window <- windowNew + windowSetTitle window "Leksah detached window" + widgetSetName window id + case size of + Just (width, height) -> do + windowSetDefaultSize window width height + Nothing -> do + (curWidth, curHeight) <- widgetGetSize activeNotebook + windowSetDefaultSize window curWidth curHeight + containerRemove (castToContainer parent) activeNotebook + containerAdd window activeNotebook + widgetShowAll window + return window + handleFunc <- runInIO (handleReattach id window) + liftIO $ window `onDelete` handleFunc + windows <- getWindowsSt + setWindowsSt $ windows ++ [window] + adjustLayoutForDetach id panePath + return (Just (window, castToWidget activeNotebook)) + _ -> return Nothing + + + +handleReattach :: PaneMonad alpha => String -> Window -> Event -> alpha Bool +handleReattach windowId window _ = do + layout <- getLayout + case findDetachedPath windowId layout of + Nothing -> trace ("ViewFrame>>handleReattach: panePath for id not found: " ++ windowId) + $ do + windows <- getWindowsSt + setWindowsSt $ delete window windows + return False + Just pp -> do + nb <- (getNotebook' "handleReattach") pp + parent <- getNotebookOrPaned (init pp) castToContainer + liftIO $ containerRemove (castToContainer window) nb + liftIO $ containerAdd parent nb + adjustLayoutForReattach pp + windows <- getWindowsSt + setWindowsSt $ delete window windows + case last pp of + GroupP groupName -> do + label <- groupLabel groupName + liftIO $ notebookSetTabLabel ((castToNotebook' "handleReattach") parent) nb label + otherwise -> return () + return False -- "now destroy the window" + + + +groupMenuLabel :: PaneMonad beta => String -> beta (Maybe Label) +groupMenuLabel group = liftM Just (liftIO $ labelNew (Just group)) + +handleNotebookSwitch :: PaneMonad beta => Notebook -> Int -> beta () +handleNotebookSwitch nb index = do + mbW <- liftIO $ notebookGetNthPage nb index + case mbW of + Nothing -> error "ViewFrame/handleNotebookSwitch: Can't find widget" + Just w -> do + name <- liftIO $ widgetGetName w + mbPane <- findPaneFor name + case mbPane of + Nothing -> return () + Just (PaneC p) -> makeActive p + where + findPaneFor :: PaneMonad beta => String -> beta (Maybe (IDEPane beta)) + findPaneFor n1 = do + panes' <- getPanesSt + foldM (\r (PaneC p) -> do + n2 <- liftIO $ widgetGetName (getTopWidget p) + return (if n1 == n2 then (Just (PaneC p)) else r)) + Nothing (Map.elems panes') + + +-- +-- | Moves the activePane in the given direction, if possible +-- | If their are many possibilities choose the leftmost and topmost +-- +viewMove :: PaneMonad beta => PaneDirection -> beta () +viewMove direction = do + mbPane <- getActivePaneSt + case mbPane of + Nothing -> do + return () + Just (paneName,_) -> do + (PaneC pane) <- paneFromName paneName + mbPanePath <- getActivePanePath + case mbPanePath of + Nothing -> do + return () + Just panePath -> do + layout <- getLayoutSt + case findMoveTarget panePath layout direction of + Nothing -> do + return () + Just moveTo -> move moveTo pane + +-- +-- | Find the target for a move +-- +findMoveTarget :: PanePath -> PaneLayout -> PaneDirection -> Maybe PanePath +findMoveTarget panePath layout direction= + let oppositeDir = otherDirection direction + canMove [] = [] + canMove reversedPath = + case head reversedPath of + SplitP d | d == oppositeDir + -> SplitP direction : (tail reversedPath) + GroupP group -> [] + _ -> canMove (tail reversedPath) + basePath = reverse (canMove $ reverse panePath) + in case basePath of + [] -> Nothing + _ -> let layoutP = layoutFromPath basePath layout + in Just $basePath ++ findAppropriate layoutP oppositeDir + +-- +-- | Moves the given Pane to the given path +-- +move :: RecoverablePane alpha beta delta => PanePath -> alpha -> delta () +move toPanePath pane = do + let name = paneName pane + toNB <- (getNotebook' "move") toPanePath + move' (name,toNB) + +-- +-- | Moves the given Pane to the given path, care for groups (layout, paneMap) +-- +move' :: PaneMonad alpha => (PaneName,Notebook) -> alpha () +move' (paneName,toNB) = do + paneMap <- getPaneMapSt + panes <- getPanesSt + layout <- getLayout + frameState <- getFrameState + case groupPrefix `stripPrefix` paneName of + Just group -> do + case findGroupPath group layout of + Nothing -> trace ("ViewFrame>>move': group not found: " ++ group) return () + Just fromPath -> do + groupNBOrPaned <- getNotebookOrPaned fromPath castToWidget + fromNB <- (getNotebook' "move'") (init fromPath) + case toNB `Map.lookup` (panePathFromNB frameState) of + Nothing -> trace "ViewFrame>>move': panepath for Notebook not found1" return () + Just toPath -> do + when (fromNB /= toNB && not (isPrefixOf fromPath toPath)) $ do + mbNum <- liftIO $ notebookPageNum fromNB groupNBOrPaned + case mbNum of + Nothing -> trace "ViewFrame>>move': group notebook not found" return () + Just num -> do + liftIO $ notebookRemovePage fromNB num + label <- groupLabel group + notebookInsertOrdered toNB groupNBOrPaned group Nothing True + liftIO $ notebookSetTabLabel toNB groupNBOrPaned label + adjustPanes fromPath (toPath ++ [GroupP group]) + adjustLayoutForGroupMove fromPath toPath group + adjustNotebooks fromPath (toPath ++ [GroupP group]) + layout2 <- getLayout + return () + Nothing -> + case paneName `Map.lookup` panes of + Nothing -> trace ("ViewFrame>>move': pane not found: " ++ paneName) return () + Just (PaneC pane) -> do + case toNB `Map.lookup` (panePathFromNB frameState) of + Nothing -> trace "ViewFrame>>move': panepath for Notebook not found2" return () + Just toPath -> + case paneName `Map.lookup`paneMap of + Nothing -> trace ("ViewFrame>>move': pane data not found: " ++ paneName) + return () + Just (fromPath,_) -> do + let child = getTopWidget pane + (fromPane,cid) <- guiPropertiesFromName paneName + fromNB <- (getNotebook' "move'") fromPane + when (fromNB /= toNB) $ do + mbNum <- liftIO $ notebookPageNum fromNB child + case mbNum of + Nothing -> trace "ViewFrame>>move': widget not found" return () + Just num -> do + liftIO $ notebookRemovePage fromNB num + notebookInsertOrdered toNB child paneName Nothing False + let paneMap1 = Map.delete paneName paneMap + setPaneMapSt $ Map.insert paneName (toPath,cid) paneMap1 + +findAppropriate :: PaneLayout -> PaneDirection -> PanePath +findAppropriate (TerminalP {}) _ = [] +findAppropriate (HorizontalP t b _) LeftP = SplitP TopP : findAppropriate t LeftP +findAppropriate (HorizontalP t b _) RightP = SplitP TopP : findAppropriate t RightP +findAppropriate (HorizontalP t b _) BottomP = SplitP BottomP : findAppropriate b BottomP +findAppropriate (HorizontalP t b _) TopP = SplitP TopP : findAppropriate b TopP +findAppropriate (VerticalP l r _) LeftP = SplitP LeftP : findAppropriate l LeftP +findAppropriate (VerticalP l r _) RightP = SplitP RightP : findAppropriate r RightP +findAppropriate (VerticalP l r _) BottomP = SplitP LeftP : findAppropriate l BottomP +findAppropriate (VerticalP l r _) TopP = SplitP LeftP : findAppropriate l TopP + +-- +-- | Bring the pane to the front position in its notebook +-- +bringPaneToFront :: RecoverablePane alpha beta delta => alpha -> IO () +bringPaneToFront pane = do + let tv = getTopWidget pane + setCurrentNotebookPages tv + + +setCurrentNotebookPages widget = do + mbParent <- widgetGetParent widget + case mbParent of + Just parent -> do + setCurrentNotebookPages parent + if parent `isA` gTypeNotebook + then do + mbPageNum <- notebookPageNum ((castToNotebook' "setCurrentNotebookPage 1") parent) widget + case mbPageNum of + Just pageNum -> do + notebookSetCurrentPage ((castToNotebook' "setCurrentNotebookPage 2") parent) pageNum + return () + Nothing -> return () + else return () + Nothing -> return () + +-- +-- | Get a valid panePath from a standard path. +-- +getBestPanePath :: StandardPath -> PaneLayout -> PanePath +getBestPanePath sp pl = reverse $ getStandard' sp pl [] + where + getStandard' (GroupP group:sp) (TerminalP {paneGroups = groups}) p + | group `Map.member` groups = getStandard' sp (groups Map.! group) (GroupP group:p) + getStandard' _ (TerminalP {}) p = p + getStandard' (SplitP LeftP:sp) (VerticalP l r _) p = getStandard' sp l (SplitP LeftP:p) + getStandard' (SplitP RightP:sp) (VerticalP l r _) p = getStandard' sp r (SplitP RightP:p) + getStandard' (SplitP TopP:sp) (HorizontalP t b _) p = getStandard' sp t (SplitP TopP:p) + getStandard' (SplitP BottomP:sp) (HorizontalP t b _) p = getStandard' sp b (SplitP BottomP:p) + -- if no match get leftmost topmost + getStandard' _ (VerticalP l r _) p = getStandard' [] l (SplitP LeftP:p) + getStandard' _ (HorizontalP t b _) p = getStandard' [] t (SplitP TopP:p) + +-- +-- | Get a standard path. +-- +getBestPathForId :: PaneMonad alpha => String -> alpha PanePath +getBestPathForId id = do + p <- panePathForGroup id + l <- getLayout + return (getBestPanePath p l) + +-- +-- | Construct a new notebook +-- +newNotebook' :: IO Notebook +newNotebook' = do + nb <- notebookNew + notebookSetTabPos nb PosTop + notebookSetShowTabs nb True + notebookSetScrollable nb True + notebookSetPopup nb True + return nb + +-- +-- | Construct a new notebook, +-- +newNotebook :: PaneMonad alpha => PanePath -> alpha Notebook +newNotebook pp = do + st <- getFrameState + nb <- liftIO newNotebook' + setPanePathFromNB $ Map.insert nb pp (panePathFromNB st) + func <- runInIO move' + liftIO $ do + tl <- targetListNew + targetListAddTextTargets tl 0 + dragDestSet nb [DestDefaultAll] [ActionCopy, ActionMove] + dragDestSetTargetList nb tl + on nb dragDataReceived (dragFunc nb func) + return nb + where + dragFunc :: + Notebook -> + ((PaneName,Notebook) -> IO ()) -> + DragContext -> + Point -> + InfoId -> + TimeStamp -> + (SelectionDataM ()) + dragFunc nb func cont point id timeStamp = do + mbText <- selectionDataGetText + case mbText of + Nothing -> return () + Just str -> do + liftIO $ func (str,nb) + return () + +terminalsWithPanePath :: PaneLayout -> [(PanePath,PaneLayout)] +terminalsWithPanePath pl = map (\ (pp,l) -> (reverse pp,l)) $ terminalsWithPP [] pl + where + terminalsWithPP pp t@(TerminalP groups _ _ _ _) = [(pp,t)] + ++ concatMap (terminalsFromGroup pp) (Map.toList groups) + terminalsWithPP pp (VerticalP l r _) = terminalsWithPP (SplitP LeftP : pp) l + ++ terminalsWithPP (SplitP RightP : pp) r + terminalsWithPP pp (HorizontalP t b _) = terminalsWithPP (SplitP TopP : pp) t + ++ terminalsWithPP (SplitP BottomP : pp) b + terminalsFromGroup pp (name,layout) = terminalsWithPP (GroupP name : pp) layout + +findGroupPath :: String -> PaneLayout -> Maybe PanePath +findGroupPath group layout = + let terminalPairs = terminalsWithPanePath layout + in case (filter filterFunc terminalPairs) of + [] -> Nothing + (pp,_) : [] -> Just (pp ++ [GroupP group]) + _ -> error ("ViewFrame>>group name not unique: " ++ group) + where + filterFunc (_,(TerminalP groups _ _ _ _)) = group `Set.member` Map.keysSet groups + filterFunc _ = error "ViewFrame>>findGroupPath: impossible" + +findDetachedPath :: String -> PaneLayout -> Maybe PanePath +findDetachedPath id layout = + let terminalPairs = terminalsWithPanePath layout + in case (filter filterFunc terminalPairs) of + [] -> Nothing + (pp,_) : [] -> Just pp + _ -> error ("ViewFrame>>window id not unique: " ++ id) + where + filterFunc (_,(TerminalP _ _ _ (Just lid) _)) = lid == id + filterFunc _ = False + + +allGroupNames :: PaneLayout -> Set String +allGroupNames pl = Set.unions $ map getFunc (terminalsWithPanePath pl) + where + getFunc (_,(TerminalP groups _ _ _ _)) = Map.keysSet groups + getFunc _ = error "ViewFrame>>allGroupNames: impossible" + + +-- +-- | Get another pane path which points to the other side at the same level +-- +otherSide :: PanePath -> Maybe PanePath +otherSide [] = Nothing +otherSide p = let rp = reverse p + in case head rp of + SplitP d -> Just (reverse $ SplitP (otherDirection d) : tail rp) + _ -> Nothing + +-- +-- | Get the opposite direction of a pane direction +-- +otherDirection :: PaneDirection -> PaneDirection +otherDirection LeftP = RightP +otherDirection RightP = LeftP +otherDirection TopP = BottomP +otherDirection BottomP = TopP + +-- +-- | Get the layout at the given pane path +-- +layoutFromPath :: PanePath -> PaneLayout -> PaneLayout +layoutFromPath [] l = l +layoutFromPath (GroupP group:r) (TerminalP {paneGroups = groups}) + | group `Map.member` groups = layoutFromPath r (groups Map.! group) +layoutFromPath (SplitP TopP:r) (HorizontalP t _ _) = layoutFromPath r t +layoutFromPath (SplitP BottomP:r) (HorizontalP _ b _) = layoutFromPath r b +layoutFromPath (SplitP LeftP:r) (VerticalP l _ _) = layoutFromPath r l +layoutFromPath (SplitP RightP:r) (VerticalP _ ri _) = layoutFromPath r ri +layoutFromPath pp l = error + $"inconsistent layout (layoutFromPath) " ++ show pp ++ " " ++ show l + +layoutsFromPath :: PanePath -> PaneLayout -> [PaneLayout] +layoutsFromPath (GroupP group:r) layout@(TerminalP {paneGroups = groups}) + | group `Map.member` groups + = layout:layoutsFromPath r (groups Map.! group) +layoutsFromPath [] layout = [layout] +layoutsFromPath (SplitP TopP:r) layout@(HorizontalP t b _) = layout:layoutsFromPath r t +layoutsFromPath (SplitP BottomP:r) layout@(HorizontalP t b _) = layout:layoutsFromPath r b +layoutsFromPath (SplitP LeftP:r) layout@(VerticalP l ri _) = layout:layoutsFromPath r l +layoutsFromPath (SplitP RightP:r) layout@(VerticalP l ri _) = layout:layoutsFromPath r ri +layoutsFromPath pp l = error + $"inconsistent layout (layoutsFromPath) " ++ show pp ++ " " ++ show l + +getWidgetNameList :: PanePath -> PaneLayout -> [String] +getWidgetNameList path layout = reverse $ nameList (reverse path) (reverse $ layoutsFromPath path layout) + where + nameList [] _ = reverse ["Leksah Main Window","topBox","root"] + nameList (pe:_) (TerminalP{detachedId = Just id}:_) = [panePathElementToWidgetName pe, id] + nameList (pe:rpath) (_:rlayout) = panePathElementToWidgetName pe : nameList rpath rlayout + nameList _ _ = error $ "inconsistent layout (getWidgetNameList) " ++ show path ++ " " ++ show layout + +getNotebookOrPaned :: PaneMonad alpha => PanePath -> (Widget -> beta) -> alpha beta +getNotebookOrPaned p cf = do + layout <- getLayout + (widgetGet $ getWidgetNameList p layout) cf + +-- +-- | Get the notebook widget for the given pane path +-- +getNotebook :: PaneMonad alpha => PanePath -> alpha Notebook +getNotebook p = getNotebookOrPaned p (castToNotebook' ("getNotebook " ++ show p)) + +getNotebook' :: PaneMonad alpha => String -> PanePath -> alpha Notebook +getNotebook' str p = getNotebookOrPaned p (castToNotebook' ("getNotebook' " ++ str ++ " " ++ show p)) + + +-- +-- | Get the (gtk) Paned widget for a given path +-- +getPaned :: PaneMonad alpha => PanePath -> alpha Paned +getPaned p = getNotebookOrPaned p castToPaned + +-- +-- | Get the path to the active pane +-- +getActivePanePath :: PaneMonad alpha => alpha (Maybe PanePath) +getActivePanePath = do + mbPane <- getActivePaneSt + case mbPane of + Nothing -> return Nothing + Just (paneName,_) -> do + (pp,_) <- guiPropertiesFromName paneName + return (Just (pp)) + +getActivePanePathOrStandard :: PaneMonad alpha => StandardPath -> alpha (PanePath) +getActivePanePathOrStandard sp = do + mbApp <- getActivePanePath + case mbApp of + Just app -> return app + Nothing -> do + layout <- getLayoutSt + return (getBestPanePath sp layout) + +-- +-- | Get the active notebook +-- +getActiveNotebook :: PaneMonad alpha => alpha (Maybe Notebook) +getActiveNotebook = do + mbPanePath <- getActivePanePath + case mbPanePath of + Just panePath -> do + nb <- (getNotebook' "getActiveNotebook") panePath + return (Just nb) + Nothing -> return Nothing + + +-- +-- | Translates a pane direction to the widget name +-- +paneDirectionToWidgetName :: PaneDirection -> String +paneDirectionToWidgetName TopP = "top" +paneDirectionToWidgetName BottomP = "bottom" +paneDirectionToWidgetName LeftP = "left" +paneDirectionToWidgetName RightP = "right" + +panePathElementToWidgetName :: PanePathElement -> String +panePathElementToWidgetName (SplitP dir) = paneDirectionToWidgetName dir +panePathElementToWidgetName (GroupP group) = groupPrefix ++ group + +-- +-- | Changes a pane path in the pane map +-- +adjustPanes :: PaneMonad alpha => PanePath -> PanePath -> alpha () +adjustPanes fromPane toPane = do + paneMap <- getPaneMapSt + setPaneMapSt (Map.map (\(pp,other) -> + case stripPrefix fromPane pp of + Just rest -> (toPane ++ rest,other) + _ -> (pp,other)) paneMap) + +adjustNotebooks :: PaneMonad alpha => PanePath -> PanePath -> alpha () +adjustNotebooks fromPane toPane = do + npMap <- trace ("+++ adjustNotebooks from: " ++ show fromPane ++ " to " ++ show toPane) + getPanePathFromNB + setPanePathFromNB (Map.map (\pp -> + case stripPrefix fromPane pp of + Just rest -> toPane ++ rest + _ -> pp) npMap) + +-- +-- | Changes the layout for a split +-- +adjustLayoutForSplit :: PaneMonad alpha => PaneDirection -> PanePath -> alpha () +adjustLayoutForSplit dir path = do + layout <- getLayoutSt + let paneLayout = layoutFromPath path layout + newLayout = TerminalP Map.empty Nothing 0 Nothing Nothing + newTerm = case dir of + LeftP -> VerticalP paneLayout newLayout 0 + RightP -> VerticalP newLayout paneLayout 0 + TopP -> HorizontalP paneLayout newLayout 0 + BottomP -> HorizontalP newLayout paneLayout 0 + setLayoutSt $ adjustLayout path layout newTerm + +-- +-- | Changes the layout for a nest +-- +adjustLayoutForNest :: PaneMonad alpha => String -> PanePath -> alpha () +adjustLayoutForNest group path = do + layout <- getLayoutSt + let paneLayout = layoutFromPath path layout + newTerm = case paneLayout of + (TerminalP {paneGroups = groups}) -> paneLayout { + paneGroups = Map.insert group (TerminalP Map.empty Nothing 0 Nothing Nothing) groups} + _ -> error "Unexpected layout type in adjustLayoutForNest" + setLayoutSt $ adjustLayout path layout newTerm + +-- +-- | Changes the layout for a detach +-- +adjustLayoutForDetach :: PaneMonad alpha => String -> PanePath -> alpha () +adjustLayoutForDetach id path = do + layout <- getLayoutSt + let paneLayout = layoutFromPath path layout + newTerm = case paneLayout of + (TerminalP {}) -> paneLayout {detachedId = Just id} + _ -> error "Unexpected layout type in adjustLayoutForDetach" + setLayoutSt $ adjustLayout path layout newTerm + +-- +-- | Changes the layout for a reattach +-- +adjustLayoutForReattach :: PaneMonad alpha => PanePath -> alpha () +adjustLayoutForReattach path = do + layout <- getLayoutSt + let paneLayout = layoutFromPath path layout + newTerm = case paneLayout of + (TerminalP {}) -> paneLayout {detachedId = Nothing, detachedSize = Nothing} + _ -> error "Unexpected layout type in adjustLayoutForReattach" + setLayoutSt $ adjustLayout path layout newTerm + +-- +-- | Changes the layout for a collapse +-- +adjustLayoutForCollapse :: PaneMonad alpha => PanePath -> alpha () +adjustLayoutForCollapse oldPath = do + layout <- getLayoutSt + let pathLayout = layoutFromPath oldPath layout + setLayoutSt $ adjustLayout (init oldPath) layout pathLayout + +-- +-- | Changes the layout for a move +-- +adjustLayoutForGroupMove :: PaneMonad alpha => PanePath -> PanePath -> String -> alpha () +adjustLayoutForGroupMove fromPath toPath group = do + layout <- getLayout + let layoutToMove = layoutFromPath fromPath layout + let newLayout = removeGL fromPath layout + setLayoutSt (addGL layoutToMove (toPath ++ [GroupP group]) newLayout) + +-- +-- | Changes the layout for a remove +-- +adjustLayoutForGroupRemove :: PaneMonad alpha => PanePath -> String -> alpha () +adjustLayoutForGroupRemove fromPath group = do + layout <- getLayout + setLayoutSt (removeGL fromPath layout) + +-- +-- | Remove group layout at a certain path +-- +removeGL :: PanePath -> PaneLayout -> PaneLayout +removeGL [GroupP group] t@(TerminalP oldGroups _ _ _ _) + | group `Map.member` oldGroups = t{paneGroups = group `Map.delete` oldGroups} +removeGL (GroupP group:r) old@(TerminalP {paneGroups = groups}) + | group `Map.member` groups = old{paneGroups = Map.adjust (removeGL r) group groups} +removeGL (SplitP TopP:r) (HorizontalP tp bp _) = HorizontalP (removeGL r tp) bp 0 +removeGL (SplitP BottomP:r) (HorizontalP tp bp _) = HorizontalP tp (removeGL r bp) 0 +removeGL (SplitP LeftP:r) (VerticalP lp rp _) = VerticalP (removeGL r lp) rp 0 +removeGL (SplitP RightP:r) (VerticalP lp rp _) = VerticalP lp (removeGL r rp) 0 +removeGL p l = error $"ViewFrame>>removeGL: inconsistent layout " ++ show p ++ " " ++ show l + +-- +-- | Add group layout at a certain path +-- +addGL :: PaneLayout -> PanePath -> PaneLayout -> PaneLayout +addGL toAdd [GroupP group] t@(TerminalP oldGroups _ _ _ _) = t{paneGroups = Map.insert group toAdd oldGroups} +addGL toAdd (GroupP group:r) old@(TerminalP {paneGroups = groups}) + | group `Map.member` groups = old{paneGroups = Map.adjust (addGL toAdd r) group groups} +addGL toAdd (SplitP TopP:r) (HorizontalP tp bp _) = HorizontalP (addGL toAdd r tp) bp 0 +addGL toAdd (SplitP BottomP:r) (HorizontalP tp bp _) = HorizontalP tp (addGL toAdd r bp) 0 +addGL toAdd (SplitP LeftP:r) (VerticalP lp rp _) = VerticalP (addGL toAdd r lp) rp 0 +addGL toAdd (SplitP RightP:r) (VerticalP lp rp _) = VerticalP lp (addGL toAdd r rp) 0 +addGL _ p l = error $"ViewFrame>>addGL: inconsistent layout" ++ show p ++ " " ++ show l + +-- +-- | Changes the layout by replacing element at pane path (pp) with replace +-- +adjustLayout :: PanePath -> PaneLayout -> PaneLayout -> PaneLayout +adjustLayout pp layout replace = adjust' pp layout + where + adjust' [] _ = replace + adjust' (GroupP group:r) old@(TerminalP {paneGroups = groups}) + | group `Map.member` groups = + old{paneGroups = Map.adjust (adjustPaneGroupLayout r) group groups} + adjust' (SplitP TopP:r) (HorizontalP tp bp _) = HorizontalP (adjust' r tp) bp 0 + adjust' (SplitP BottomP:r) (HorizontalP tp bp _) = HorizontalP tp (adjust' r bp) 0 + adjust' (SplitP LeftP:r) (VerticalP lp rp _) = VerticalP (adjust' r lp) rp 0 + adjust' (SplitP RightP:r) (VerticalP lp rp _) = VerticalP lp (adjust' r rp) 0 + adjust' p l = error $"inconsistent layout (adjust) " ++ show p ++ " " ++ show l + adjustPaneGroupLayout p group = adjust' p group + +-- +-- | Get the widget from a list of strings +-- +widgetFromPath :: Widget -> [String] -> IO (Widget) +widgetFromPath w [] = return w +widgetFromPath w path = do + children <- containerGetChildren (castToContainer w) + chooseWidgetFromPath children path + +chooseWidgetFromPath :: [Widget] -> [String] -> IO (Widget) +chooseWidgetFromPath _ [] = error $"Cant't find widget (empty path)" +chooseWidgetFromPath widgets (h:t) = do + names <- mapM widgetGetName widgets + let mbiInd = findIndex (== h) names + case mbiInd of + Nothing -> error $"Cant't find widget path " ++ show (h:t) ++ " found only " ++ show names + Just ind -> widgetFromPath (widgets !! ind) t + +widgetGet :: PaneMonad alpha => [String] -> (Widget -> b) -> alpha (b) +widgetGet strL cf = do + windows <- getWindowsSt + r <- liftIO $chooseWidgetFromPath (map castToWidget windows) strL + return (cf r) + +widgetGetRel :: Widget -> [String] -> (Widget -> b) -> IO (b) +widgetGetRel w sl cf = do + r <- widgetFromPath w sl + return (cf r) + +getUIAction :: PaneMonad alpha => String -> (Action -> a) -> alpha (a) +getUIAction str f = do + uiManager <- getUiManagerSt + liftIO $ do + findAction <- uiManagerGetAction uiManager str + case findAction of + Just act -> return (f act) + Nothing -> error $"getUIAction can't find action " ++ str + +getThis :: PaneMonad delta => (FrameState delta -> alpha) -> delta alpha +getThis sel = do + st <- getFrameState + return (sel st) +setThis :: PaneMonad delta => (FrameState delta -> alpha -> FrameState delta) -> alpha -> delta () +setThis sel value = do + st <- getFrameState + trace ("!!! setFrameState " ++ show (sel st value)) $ setFrameState (sel st value) + +getWindowsSt = getThis windows +setWindowsSt = setThis (\st value -> st{windows = value}) +getUiManagerSt = getThis uiManager +getPanesSt = getThis panes +setPanesSt = setThis (\st value -> st{panes = value}) +getPaneMapSt = getThis paneMap +setPaneMapSt = setThis (\st value -> st{paneMap = value}) +getActivePaneSt = getThis activePane +setActivePaneSt = setThis (\st value -> st{activePane = value}) +getLayoutSt = getThis layout +setLayoutSt = setThis (\st value -> st{layout = value}) +getPanePathFromNB = getThis panePathFromNB +setPanePathFromNB = setThis (\st value -> st{panePathFromNB = value}) + +getActivePane = getActivePaneSt +setActivePane = setActivePaneSt +getUiManager = getUiManagerSt +getWindows = getWindowsSt +getMainWindow = liftM head getWindows +getLayout = getLayoutSt + +castToNotebook' :: GObjectClass obj => String -> obj -> Notebook +castToNotebook' str obj = if obj `isA` gTypeNotebook + then castToNotebook obj + else error ("Not a notebook " ++ str) + diff --git a/src/MyMissing.hs b/src/MyMissing.hs new file mode 100644 --- /dev/null +++ b/src/MyMissing.hs @@ -0,0 +1,82 @@ +{-# OPTIONS_GHC -XScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Module : MyMissing +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- Stability : provisional +-- Portability : portable +-- +-- | Module for missing base functions +-- +------------------------------------------------------------------------------ + +module MyMissing ( + allOf +, forceJust +, forceHead +, split +, replace +, nonEmptyLines +, trim +) where + +import Data.List (find,unfoldr) +import Data.Maybe (isJust) +import Data.Char (isSpace) + + +-- | remove leading and trailing spaces +trim :: String -> String +trim = f . f + where f = reverse . dropWhile isSpace + +nonEmptyLines :: String -> [String] +nonEmptyLines = filter (\line -> isJust $ find (not . isSpace) line) . lines + + +allOf :: forall alpha. (Bounded alpha, Enum alpha) => [alpha] +allOf = map toEnum [fromEnum (minBound :: alpha) .. fromEnum (maxBound :: alpha)] + +-- --------------------------------------------------------------------- +-- Convenience methods with error handling +-- +forceJust :: Maybe alpha -> String -> alpha +forceJust mb str = case mb of + Nothing -> error str + Just it -> it + +-- --------------------------------------------------------------------- +-- Convenience methods with error handling +-- +forceHead :: [alpha] -> String -> alpha +forceHead (h:_) str = h +forceHead [] str = error str + + +-- --------------------------------------------------------------------- +-- Splitting a string into parts based on a token delimiter +-- + +split :: Eq a => a -> [a] -> [[a]] +split = unfoldr . split' + +split' :: Eq a => a -> [a] -> Maybe ([a], [a]) +split' c l + | null l = Nothing + | otherwise = Just (h, drop 1 t) + where (h, t) = span (/=c) l + +-- --------------------------------------------------------------------- +-- Simple replacement +-- + +replace :: Eq a => [a] -> [a] -> [a] -> [a] +replace _ _ [] = [] +replace from to xs@(a:as) = + if isPrefixOf from xs + then to ++ replace from to (drop (length from) xs) + else a : replace from to as + where isPrefixOf as bs = and $ zipWith (== ) as bs diff --git a/src/Text/PrinterParser.hs b/src/Text/PrinterParser.hs new file mode 100644 --- /dev/null +++ b/src/Text/PrinterParser.hs @@ -0,0 +1,244 @@ +{-# OPTIONS_GHC -XTypeSynonymInstances #-} +-- +-- | Module for saving and restoring preferences and settings +-- + +module Text.PrinterParser ( + + Printer +, Parser +, FieldDescriptionS(..) +, MkFieldDescriptionS +, mkFieldS + +, applyFieldParsers +, boolParser +, intParser +, lineParser +, pairParser +, identifier +, emptyParser +, whiteSpace +, stringParser +, readParser +, colorParser + +, emptyPrinter +, Pretty(..) +, prettyPrint +, maybePP + +, symbol +, colon + +, writeFields +, showFields +, readFields +, parseFields +) where + +import Text.ParserCombinators.Parsec.Language +import qualified Text.ParserCombinators.Parsec.Token as P +import Text.ParserCombinators.Parsec hiding(Parser) +import qualified Text.PrettyPrint as PP + +import Graphics.UI.Editor.Parameters +import Graphics.UI.Editor.Basics +import Data.Maybe (listToMaybe) +import Graphics.UI.Gtk (Color(..)) +import Data.List (foldl') +import qualified Text.ParserCombinators.Parsec as P + ((), CharParser(..), parseFromFile) + + +type Printer beta = beta -> PP.Doc +type Parser beta = CharParser () beta + +-- ------------------------------------------------------------ +-- * Parsing with Parsec +-- ------------------------------------------------------------ + +data FieldDescriptionS alpha = FDS { + parameters :: Parameters + , fieldPrinter :: alpha -> PP.Doc + , fieldParser :: alpha -> CharParser () alpha + } + +type MkFieldDescriptionS alpha beta = + Parameters -> + (Printer beta) -> + (Parser beta) -> + (Getter alpha beta) -> + (Setter alpha beta) -> + FieldDescriptionS alpha + +mkFieldS :: {--Eq beta =>--} MkFieldDescriptionS alpha beta +mkFieldS parameter printer parser getter setter = + FDS parameter + (\ dat -> (PP.text (case getParameterPrim paraName parameter of + Nothing -> "" + Just str -> str) PP.<> PP.colon) + PP.$$ (PP.nest 15 (printer (getter dat))) + PP.$$ (PP.nest 5 (case getParameterPrim paraSynopsis parameter of + Nothing -> PP.empty + Just str -> PP.text $"--" ++ str))) + (\ dat -> try (do + symbol (case getParameterPrim paraName parameter of + Nothing -> "" + Just str -> str) + colon + val <- parser + return (setter val dat))) + +applyFieldParsers :: a -> [a -> CharParser () a] -> CharParser () a +applyFieldParsers prefs parseF = do + eof + return (prefs) + <|> do + let parsers = map (\a -> a prefs) parseF + newprefs <- choice parsers + whiteSpace + applyFieldParsers newprefs parseF + "field parser" + +boolParser :: CharParser () Bool +boolParser = do + (symbol "True" <|> symbol "true") + return True + <|> do + (symbol "False"<|> symbol "false") + return False + "bool parser" + + +readParser :: Read a => CharParser () a +readParser = do + str <- many (noneOf ['\n']) + if null str + then unexpected "read parser on empty string" + else do + case maybeRead str of + Nothing -> unexpected $ "read parser no parse " ++ str + Just r -> return r + "read parser" + where maybeRead = listToMaybe . map fst . filter (null . snd) . reads + +pairParser :: CharParser () alpha -> CharParser () (alpha,alpha) +pairParser p2 = do + char '(' + v1 <- p2 + char ',' + v2 <- p2 + char ')' + return (v1,v2) + "pair parser" + +stringParser :: CharParser () String +stringParser = do + char '"' + str <- many (noneOf ['"']) + char '"' + return (str) + "string parser" + +lineParser :: CharParser () String +lineParser = do + str <- many (noneOf ['\n']) + return (str) + "line parser" + + +intParser :: CharParser () Int +intParser = do + i <- integer + return (fromIntegral i) + +colorParser :: CharParser () Color +colorParser = do + string "Color" + whiteSpace + r <- integer + whiteSpace + g <- integer + whiteSpace + b <- integer + return $ Color (fromIntegral r) (fromIntegral g) (fromIntegral b) + +emptyParser :: CharParser () () +emptyParser = pzero + +prefsStyle :: P.LanguageDef st +prefsStyle = emptyDef { + P.commentStart = "{-" + , P.commentEnd = "-}" + , P.commentLine = "--" + } + +lexer :: P.TokenParser st +lexer = P.makeTokenParser prefsStyle + +whiteSpace :: CharParser st () +whiteSpace = P.whiteSpace lexer + +symbol :: String -> CharParser st String +symbol = P.symbol lexer + +identifier, colon :: CharParser st String +identifier = P.identifier lexer +colon = P.colon lexer + +integer = P.integer lexer + +-- ------------------------------------------------------------ +-- * Printing +-- ------------------------------------------------------------ +-- | pretty-print with the default style and 'defaultMode'. +prettyPrint :: Pretty a => a -> String +prettyPrint a = PP.renderStyle PP.style (pretty a) + +-- | Things that can be pretty-printed +class Pretty a where + -- | Pretty-print something in isolation. + pretty :: a -> PP.Doc + -- | Pretty-print something in a precedence context. + prettyPrec :: Int -> a -> PP.Doc + pretty = prettyPrec 0 + prettyPrec _ = pretty + +emptyPrinter :: () -> PP.Doc +emptyPrinter _ = PP.empty + +maybePP :: (a -> PP.Doc) -> Maybe a -> PP.Doc +maybePP _ Nothing = PP.empty +maybePP pp (Just a) = pp a + +instance Pretty String where + pretty str = PP.text str + +-- ------------------------------------------------------------ +-- * Read and write +-- ------------------------------------------------------------ + +writeFields :: FilePath -> alpha -> [FieldDescriptionS alpha] -> IO () +writeFields fpath date dateDesc = writeFile fpath (showFields date dateDesc) + +showFields :: alpha -> [FieldDescriptionS alpha] -> String +showFields date dateDesc = PP.render $ + foldl' (\ doc (FDS _ printer _) -> doc PP.$+$ printer date) PP.empty dateDesc + +readFields :: FilePath -> [FieldDescriptionS alpha] -> alpha -> IO alpha +readFields fn fieldDescrs defaultValue = catch (do + res <- P.parseFromFile (parseFields defaultValue fieldDescrs) fn + case res of + Left pe -> error $ "Error reading file " ++ show fn ++ " " ++ show pe + Right r -> return r) + (\ e -> error $ "Error reading file " ++ show fn ++ " " ++ show e) + +parseFields :: alpha -> [FieldDescriptionS alpha] -> P.CharParser () alpha +parseFields defaultValue descriptions = + let parsersF = map fieldParser descriptions in do + res <- applyFieldParsers defaultValue parsersF + return res + P. "prefs parser" + +