ltk (empty) → 0.8
raw patch · 15 files changed
+4881/−0 lines, 15 filesdep +Cabaldep +basedep +containerssetup-changed
Dependencies added: Cabal, base, containers, filepath, glib, gtk, mtl, parsec, pretty
Files
- LICENSE +339/−0
- Setup.lhs +6/−0
- ltk.cabal +53/−0
- src/Control/Event.hs +86/−0
- src/Default.hs +46/−0
- src/Graphics/UI/Editor/Basics.hs +285/−0
- src/Graphics/UI/Editor/Composite.hs +788/−0
- src/Graphics/UI/Editor/DescriptionPP.hs +100/−0
- src/Graphics/UI/Editor/MakeEditor.hs +258/−0
- src/Graphics/UI/Editor/Parameters.hs +184/−0
- src/Graphics/UI/Editor/Simple.hs +783/−0
- src/Graphics/UI/Frame/Panes.hs +234/−0
- src/Graphics/UI/Frame/ViewFrame.hs +1393/−0
- src/MyMissing.hs +82/−0
- src/Text/PrinterParser.hs +244/−0
+ LICENSE view
@@ -0,0 +1,339 @@+ GNU GENERAL PUBLIC LICENSE+ Version 2, June 1991++ Copyright (C) 1989, 1991 Free Software Foundation, Inc.,+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The licenses for most software are designed to take away your+freedom to share and change it. By contrast, the GNU General Public+License is intended to guarantee your freedom to share and change free+software--to make sure the software is free for all its users. This+General Public License applies to most of the Free Software+Foundation's software and to any other program whose authors commit to+using it. (Some other Free Software Foundation software is covered by+the GNU Lesser General Public License instead.) You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+this service if you wish), that you receive source code or can get it+if you want it, that you can change the software or use pieces of it+in new free programs; and that you know you can do these things.++ To protect your rights, we need to make restrictions that forbid+anyone to deny you these rights or to ask you to surrender the rights.+These restrictions translate to certain responsibilities for you if you+distribute copies of the software, or if you modify it.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must give the recipients all the rights that+you have. You must make sure that they, too, receive or can get the+source code. And you must show them these terms so they know their+rights.++ We protect your rights with two steps: (1) copyright the software, and+(2) offer you this license which gives you legal permission to copy,+distribute and/or modify the software.++ Also, for each author's protection and ours, we want to make certain+that everyone understands that there is no warranty for this free+software. If the software is modified by someone else and passed on, we+want its recipients to know that what they have is not the original, so+that any problems introduced by others will not reflect on the original+authors' reputations.++ Finally, any free program is threatened constantly by software+patents. We wish to avoid the danger that redistributors of a free+program will individually obtain patent licenses, in effect making the+program proprietary. To prevent this, we have made it clear that any+patent must be licensed for everyone's free use or not licensed at all.++ The precise terms and conditions for copying, distribution and+modification follow.++ GNU GENERAL PUBLIC LICENSE+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++ 0. This License applies to any program or other work which contains+a notice placed by the copyright holder saying it may be distributed+under the terms of this General Public License. The "Program", below,+refers to any such program or work, and a "work based on the Program"+means either the Program or any derivative work under copyright law:+that is to say, a work containing the Program or a portion of it,+either verbatim or with modifications and/or translated into another+language. (Hereinafter, translation is included without limitation in+the term "modification".) Each licensee is addressed as "you".++Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope. The act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the+Program (independent of having been made by running the Program).+Whether that is true depends on what the Program does.++ 1. You may copy and distribute verbatim copies of the Program's+source code as you receive it, in any medium, provided that you+conspicuously and appropriately publish on each copy an appropriate+copyright notice and disclaimer of warranty; keep intact all the+notices that refer to this License and to the absence of any warranty;+and give any other recipients of the Program a copy of this License+along with the Program.++You may charge a fee for the physical act of transferring a copy, and+you may at your option offer warranty protection in exchange for a fee.++ 2. You may modify your copy or copies of the Program or any portion+of it, thus forming a work based on the Program, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++ a) You must cause the modified files to carry prominent notices+ stating that you changed the files and the date of any change.++ b) You must cause any work that you distribute or publish, that in+ whole or in part contains or is derived from the Program or any+ part thereof, to be licensed as a whole at no charge to all third+ parties under the terms of this License.++ c) If the modified program normally reads commands interactively+ when run, you must cause it, when started running for such+ interactive use in the most ordinary way, to print or display an+ announcement including an appropriate copyright notice and a+ notice that there is no warranty (or else, saying that you provide+ a warranty) and that users may redistribute the program under+ these conditions, and telling the user how to view a copy of this+ License. (Exception: if the Program itself is interactive but+ does not normally print such an announcement, your work based on+ the Program is not required to print an announcement.)++These requirements apply to the modified work as a whole. If+identifiable sections of that work are not derived from the Program,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works. But when you+distribute the same sections as part of a whole which is a work based+on the Program, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work based on the Program) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++ 3. You may copy and distribute the Program (or a work based on it,+under Section 2) in object code or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++ a) Accompany it with the complete corresponding machine-readable+ source code, which must be distributed under the terms of Sections+ 1 and 2 above on a medium customarily used for software interchange; or,++ b) Accompany it with a written offer, valid for at least three+ years, to give any third party, for a charge no more than your+ cost of physically performing source distribution, a complete+ machine-readable copy of the corresponding source code, to be+ distributed under the terms of Sections 1 and 2 above on a medium+ customarily used for software interchange; or,++ c) Accompany it with the information you received as to the offer+ to distribute corresponding source code. (This alternative is+ allowed only for noncommercial distribution and only if you+ received the program in object code or executable form with such+ an offer, in accord with Subsection b above.)++The source code for a work means the preferred form of the work for+making modifications to it. For an executable work, complete source+code means all the source code for all modules it contains, plus any+associated interface definition files, plus the scripts used to+control compilation and installation of the executable. However, as a+special exception, the source code distributed need not include+anything that is normally distributed (in either source or binary+form) with the major components (compiler, kernel, and so on) of the+operating system on which the executable runs, unless that component+itself accompanies the executable.++If distribution of executable or object code is made by offering+access to copy from a designated place, then offering equivalent+access to copy the source code from the same place counts as+distribution of the source code, even though third parties are not+compelled to copy the source along with the object code.++ 4. You may not copy, modify, sublicense, or distribute the Program+except as expressly provided under this License. Any attempt+otherwise to copy, modify, sublicense or distribute the Program is+void, and will automatically terminate your rights under this License.+However, parties who have received copies, or rights, from you under+this License will not have their licenses terminated so long as such+parties remain in full compliance.++ 5. You are not required to accept this License, since you have not+signed it. However, nothing else grants you permission to modify or+distribute the Program or its derivative works. These actions are+prohibited by law if you do not accept this License. Therefore, by+modifying or distributing the Program (or any work based on the+Program), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Program or works based on it.++ 6. Each time you redistribute the Program (or any work based on the+Program), the recipient automatically receives a license from the+original licensor to copy, distribute or modify the Program subject to+these terms and conditions. You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties to+this License.++ 7. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Program at all. For example, if a patent+license would not permit royalty-free redistribution of the Program by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Program.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system, which is+implemented by public license practices. Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++ 8. If the distribution and/or use of the Program is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Program under this License+may add an explicit geographical distribution limitation excluding+those countries, so that distribution is permitted only in or among+countries not thus excluded. In such case, this License incorporates+the limitation as if written in the body of this License.++ 9. The Free Software Foundation may publish revised and/or new versions+of the General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++Each version is given a distinguishing version number. If the Program+specifies a version number of this License which applies to it and "any+later version", you have the option of following the terms and conditions+either of that version or of any later version published by the Free+Software Foundation. If the Program does not specify a version number of+this License, you may choose any version ever published by the Free Software+Foundation.++ 10. If you wish to incorporate parts of the Program into other free+programs whose distribution conditions are different, write to the author+to ask for permission. For software which is copyrighted by the Free+Software Foundation, write to the Free Software Foundation; we sometimes+make exceptions for this. Our decision will be guided by the two goals+of preserving the free status of all derivatives of our free software and+of promoting the sharing and reuse of software generally.++ NO WARRANTY++ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,+REPAIR OR CORRECTION.++ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE+POSSIBILITY OF SUCH DAMAGES.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License along+ with this program; if not, write to the Free Software Foundation, Inc.,+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.++Also add information on how to contact you by electronic and paper mail.++If the program is interactive, make it output a short notice like this+when it starts in an interactive mode:++ Gnomovision version 69, Copyright (C) year name of author+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, the commands you use may+be called something other than `show w' and `show c'; they could even be+mouse-clicks or menu items--whatever suits your program.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the program, if+necessary. Here is a sample; alter the names:++ Yoyodyne, Inc., hereby disclaims all copyright interest in the program+ `Gnomovision' (which makes passes at compilers) written by James Hacker.++ <signature of Ty Coon>, 1 April 1989+ Ty Coon, President of Vice++This General Public License does not permit incorporating your program into+proprietary programs. If your program is a subroutine library, you may+consider it more useful to permit linking proprietary applications with the+library. If this is what you want to do, use the GNU Lesser General+Public License instead of this License.
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain +
+ ltk.cabal view
@@ -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:
+ src/Control/Event.hs view
@@ -0,0 +1,86 @@+{-# OPTIONS_GHC -XMultiParamTypeClasses -XFunctionalDependencies #-}+-----------------------------------------------------------------------------+--+-- Module : Control.Event+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- 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+
+ src/Default.hs view
@@ -0,0 +1,46 @@++-----------------------------------------------------------------------------+--+-- Module : Default+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info@leksah.org>+-- 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+
+ src/Graphics/UI/Editor/Basics.hs view
@@ -0,0 +1,285 @@+{-# OPTIONS_GHC -XMultiParamTypeClasses -XScopedTypeVariables #-}++-----------------------------------------------------------------------------+--+-- Module : Graphics.UI.Editor.Basics+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- 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"
+ src/Graphics/UI/Editor/Composite.hs view
@@ -0,0 +1,788 @@+-----------------------------------------------------------------------------+--+-- Module : Graphics.UI.Editor.Composite+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- 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++++++
+ src/Graphics/UI/Editor/DescriptionPP.hs view
@@ -0,0 +1,100 @@+-----------------------------------------------------------------------------+--+-- Module : Graphics.UI.Editor.DescriptionPP+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- 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"+
+ src/Graphics/UI/Editor/MakeEditor.hs view
@@ -0,0 +1,258 @@+-----------------------------------------------------------------------------+--group_Test+-- Module : Graphics.UI.Editor.MakeEditor+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- 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)++++
+ src/Graphics/UI/Editor/Parameters.hs view
@@ -0,0 +1,184 @@+-----------------------------------------------------------------------------+--+-- Module : Graphics.UI.Editor.Parameters+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- 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+ ]+
+ src/Graphics/UI/Editor/Simple.hs view
@@ -0,0 +1,783 @@+{-# OPTIONS_GHC -XScopedTypeVariables #-}+-----------------------------------------------------------------------------+--+-- Module : Graphics.UI.Editor.Simple+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- 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]+
+ src/Graphics/UI/Frame/Panes.hs view
@@ -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 : <maintainer at leksah.org>+-- 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
+ src/Graphics/UI/Frame/ViewFrame.hs view
@@ -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 : <maintainer at leksah.org>+-- 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 ("<b>" ++ group ++ "</b>")+ 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 "<span foreground=\"red\">" ++ text ++ "</span>"+ 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)+
+ src/MyMissing.hs view
@@ -0,0 +1,82 @@+{-# OPTIONS_GHC -XScopedTypeVariables #-}+-----------------------------------------------------------------------------+--+-- Module : MyMissing+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info@leksah.org>+-- 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
+ src/Text/PrinterParser.hs view
@@ -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"++