ltk-0.12.1.0/0000755000000000000000000000000011763167722010725 5ustar0000000000000000ltk-0.12.1.0/ltk.cabal0000644000000000000000000000254711763167722012513 0ustar0000000000000000name: ltk version: 0.12.1.0 cabal-version: >= 1.8 build-type: Simple license: GPL license-file: LICENSE copyright: Juergen "jutaro" Nicklisch-Franken maintainer: maintainer@leksah.org 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 || ==7.0 Library build-depends: Cabal >=1.6.0 && <1.15, base >=4.0.0.0 && <4.6, containers >=0.2 && <0.5, filepath >=1.1.0 && <1.4, glib >=0.10.0 && <0.13, gtk >=0.10.0 && <0.13, mtl >=1.1.0.2 && <2.2, parsec >=2.1.0.1 && <3.2, pretty >=1.0.1.0 && <1.2, transformers >=0.2.2.0 && <0.4, ghc -any 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 extensions: CPP, FlexibleInstances, BangPatterns hs-source-dirs: src ltk-0.12.1.0/LICENSE0000644000000000000000000004310311763167722011733 0ustar0000000000000000 GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Lesser General Public License instead.) You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. ltk-0.12.1.0/Setup.lhs0000644000000000000000000000016411763167722012536 0ustar0000000000000000#!/usr/bin/runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain ltk-0.12.1.0/src/0000755000000000000000000000000011763167722011514 5ustar0000000000000000ltk-0.12.1.0/src/MyMissing.hs0000644000000000000000000000427711763167722014001 0ustar0000000000000000{-# OPTIONS_GHC -XScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : MyMissing -- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GNU-GPL -- -- Maintainer : Juergen Nicklisch-Franken -- Stability : provisional -- Portability : portable -- -- | Module for missing base functions -- ------------------------------------------------------------------------------ module MyMissing ( allOf , forceJust , forceHead , split , replace , nonEmptyLines , trim ) where import Data.List (find,unfoldr) import Data.Maybe (isJust) import Data.Char (isSpace) -- | remove leading and trailing spaces trim :: String -> String trim = f . f where f = reverse . dropWhile isSpace nonEmptyLines :: String -> [String] nonEmptyLines = filter (\line -> isJust $ find (not . isSpace) line) . lines allOf :: forall alpha. (Bounded alpha, Enum alpha) => [alpha] allOf = map toEnum [fromEnum (minBound :: alpha) .. fromEnum (maxBound :: alpha)] -- --------------------------------------------------------------------- -- Convenience methods with error handling -- forceJust :: Maybe alpha -> String -> alpha forceJust mb str = case mb of Nothing -> error str Just it -> it -- --------------------------------------------------------------------- -- Convenience methods with error handling -- forceHead :: [alpha] -> String -> alpha forceHead (h:_) str = h forceHead [] str = error str -- --------------------------------------------------------------------- -- Splitting a string into parts based on a token delimiter -- split :: Eq a => a -> [a] -> [[a]] split = unfoldr . split' split' :: Eq a => a -> [a] -> Maybe ([a], [a]) split' c l | null l = Nothing | otherwise = Just (h, drop 1 t) where (h, t) = span (/=c) l -- --------------------------------------------------------------------- -- Simple replacement -- replace :: Eq a => [a] -> [a] -> [a] -> [a] replace _ _ [] = [] replace from to xs@(a:as) = if isPrefixOf from xs then to ++ replace from to (drop (length from) xs) else a : replace from to as where isPrefixOf as bs = and $ zipWith (== ) as bs ltk-0.12.1.0/src/Default.hs0000644000000000000000000000233511763167722013437 0ustar0000000000000000 ----------------------------------------------------------------------------- -- -- Module : Default -- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GNU-GPL -- -- Maintainer : Juergen Nicklisch-Franken -- Stability : provisional -- Portability : portable -- -- | Module for default values of a data type -- ------------------------------------------------------------------------------ module Default ( Default(..) ) where -- -- | A class for providing default values for certain types of editors -- class Default alpha where getDefault :: alpha instance Default Int where getDefault = 1 instance Default alpha => Default (Either alpha beta) where getDefault = Left getDefault instance (Default alpha, Default beta) => Default (alpha, beta) where getDefault = (getDefault,getDefault) instance (Default alpha, Default beta, Default gamma) => Default (alpha, beta, gamma) where getDefault = (getDefault,getDefault,getDefault) instance Default [alpha] where getDefault = [] instance Default (Maybe alpha) where getDefault = Nothing instance Default Bool where getDefault = True ltk-0.12.1.0/src/Graphics/0000755000000000000000000000000011763167722013254 5ustar0000000000000000ltk-0.12.1.0/src/Graphics/UI/0000755000000000000000000000000011763167722013571 5ustar0000000000000000ltk-0.12.1.0/src/Graphics/UI/Frame/0000755000000000000000000000000011763167722014623 5ustar0000000000000000ltk-0.12.1.0/src/Graphics/UI/Frame/Panes.hs0000644000000000000000000001647311763167722016240 0ustar0000000000000000{-# OPTIONS_GHC -XExistentialQuantification -XMultiParamTypeClasses -XFunctionalDependencies -XNoMonomorphismRestriction -XCPP #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Core.Panes -- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GNU-GPL -- -- Maintainer : -- Stability : provisional21 -- Portability : portable -- -- | The basic definitions for all panes -- ------------------------------------------------------------------------------- module Graphics.UI.Frame.Panes ( -- * Panes and pane layout PaneMonad(..) , IDEPane(..) , Pane(..) , RecoverablePane(..) , PaneDirection(..) , PanePathElement(..) , PanePath , PaneLayout(..) , PaneName , Connection(..) , Connections , StandardPath , FrameState(..) , signalDisconnectAll ) where import Graphics.UI.Gtk hiding (get) import System.Glib.GObject import System.Glib.Signals import Data.Maybe import Data.Map (Map) import qualified Data.Map as Map import Data.Typeable import Graphics.UI.Editor.Basics (Connection(..), Connection, Connections) import Control.Monad.IO.Class (MonadIO) -- --------------------------------------------------------------------- -- 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" 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 ltk-0.12.1.0/src/Graphics/UI/Frame/ViewFrame.hs0000644000000000000000000017171611763167722017061 0ustar0000000000000000{-# OPTIONS_GHC -XFunctionalDependencies -XNoMonomorphismRestriction -XFlexibleInstances -XMultiParamTypeClasses -XUndecidableInstances -XDeriveDataTypeable -XBangPatterns #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Core.ViewFrame -- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GNU-GPL -- -- Maintainer : -- Stability : provisional -- Portability : portable -- -- -- | Splittable panes containing notebooks with any widgets -- --------------------------------------------------------------------------------- module Graphics.UI.Frame.ViewFrame ( removePaneAdmin , addPaneAdmin , notebookInsertOrdered , markLabel -- * Convenience methods for accesing Pane state , posTypeToPaneDirection , paneDirectionToPosType , paneFromName , mbPaneFromName , guiPropertiesFromName -- * View Actions , viewMove , viewSplitHorizontal , viewSplitVertical --, viewSplit , viewSplit' , viewNewGroup , newGroupOrBringToFront , bringGroupToFront , viewNest , viewNest' , viewDetach , viewDetach' , handleNotebookSwitch , viewCollapse , viewCollapse' , viewTabsPos , viewSwitchTabs , closeGroup , allGroupNames -- * View Queries , getBestPanePath , getBestPathForId , getActivePanePath , getActivePanePathOrStandard , figureOutPaneName , getNotebook , getPaned , getActiveNotebook , getActivePane , setActivePane , getUiManager , getWindows , getMainWindow , getLayout , getPanesSt , getPaneMapSt , getPanePrim , getPanes -- * View Actions , bringPaneToFront , newNotebook , newNotebook' -- * Accessing GUI elements --, widgetFromPath , getUIAction , widgetGet , initGtkRc ) where import Graphics.UI.Gtk hiding (afterToggleOverwrite,onToggleOverwrite) import 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) #if MIN_VERSION_gtk(0,10,5) import Graphics.UI.Gtk.Layout.Notebook (gTypeNotebook) #else import Graphics.UI.Gtk.Types (gTypeNotebook) #endif import System.CPUTime (getCPUTime) #if MIN_VERSION_gtk(0,10,5) import Graphics.UI.Gtk.Gdk.EventM (Modifier(..)) #else import Graphics.UI.Gtk.Gdk.Enums (Modifier(..)) #endif 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 (eventText, GUIEventSelector(..)) import qualified Data.Set as Set (unions, member) import Data.Set (Set(..)) import Graphics.UI.Gtk.Gdk.Events (Event(..)) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad (when, liftM, foldM) import qualified Control.Monad.Reader as Gtk (liftIO) --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 () #if MIN_VERSION_gtk(0,11,0) initGtkRc = 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\"") #else initGtkRc = return () #endif removePaneAdmin :: RecoverablePane alpha beta delta => alpha -> delta () removePaneAdmin pane = do panes' <- getPanesSt paneMap' <- getPaneMapSt setPanesSt (Map.delete (paneName pane) panes') setPaneMapSt (Map.delete (paneName pane) paneMap') addPaneAdmin :: RecoverablePane alpha beta delta => alpha -> Connections -> PanePath -> delta Bool addPaneAdmin pane conn pp = do panes' <- getPanesSt paneMap' <- getPaneMapSt liftIO $ widgetSetName (getTopWidget pane) (paneName pane) let b1 = case Map.lookup (paneName pane) paneMap' of Nothing -> True Just it -> False let b2 = case Map.lookup (paneName pane) panes' of Nothing -> True Just it -> False if b1 && b2 then do setPaneMapSt (Map.insert (paneName pane) (pp, conn) paneMap') setPanesSt (Map.insert (paneName pane) (PaneC pane) panes') return True else do trace ("ViewFrame>addPaneAdmin:pane with this name already exist" ++ paneName pane) $ return False getPanePrim :: RecoverablePane alpha beta delta => delta (Maybe alpha) getPanePrim = do selectedPanes <- getPanes if null selectedPanes || length selectedPanes > 1 then return Nothing else (return (Just $ head selectedPanes)) getPanes :: RecoverablePane alpha beta delta => delta ([alpha]) getPanes = do panes' <- getPanesSt return (catMaybes $ map (\(PaneC p) -> cast p) $ Map.elems panes') notebookInsertOrdered :: PaneMonad alpha => (NotebookClass self, WidgetClass child) => self -> child -- child - the Widget to use as the contents of the page. -> String -> Maybe Label -- the label for the page as String or Label -> Bool -> alpha () notebookInsertOrdered nb widget labelStr mbLabel isGroup = do label <- case mbLabel of Nothing -> liftIO $ labelNew (Just labelStr) Just l -> return l menuLabel <- liftIO $ labelNew (Just labelStr) numPages <- liftIO $ notebookGetNPages nb mbWidgets <- liftIO $ mapM (notebookGetNthPage nb) [0 .. (numPages-1)] let widgets = map (\v -> forceJust v "ViewFrame.notebookInsertOrdered: no widget") mbWidgets labelStrs <- liftIO $ mapM widgetGetName widgets let pos = case findIndex (\ s -> withoutGroupPrefix s > withoutGroupPrefix labelStr) labelStrs of Just i -> i Nothing -> -1 labelBox <- if isGroup then groupLabel labelStr else mkLabelBox label labelStr liftIO $ do markLabel nb labelBox False realPos <- notebookInsertPageMenu nb widget labelBox menuLabel pos widgetShowAll labelBox notebookSetCurrentPage nb realPos -- | Returns a label box mkLabelBox :: PaneMonad alpha => Label -> String -> alpha EventBox mkLabelBox lbl paneName = do (tb,lb) <- liftIO $ do miscSetAlignment (castToMisc lbl) 0.0 0.0 miscSetPadding (castToMisc lbl) 0 0 labelBox <- eventBoxNew eventBoxSetVisibleWindow labelBox False innerBox <- hBoxNew False 0 tabButton <- buttonNew widgetSetName tabButton "leksah-close-button" buttonSetFocusOnClick tabButton False buttonSetRelief tabButton ReliefNone buttonSetAlignment tabButton (0.0,0.0) image <- imageNewFromStock stockClose IconSizeMenu mbPB <- widgetRenderIcon tabButton stockClose IconSizeMenu "" (height,width) <- case mbPB of Nothing -> return (14,14) Just pb -> do h <- pixbufGetHeight pb w <- pixbufGetWidth pb return (h,w) on tabButton styleSet (\style -> do widgetSetSizeRequest tabButton (height + 2) (width + 2)) containerSetBorderWidth tabButton 0 containerAdd tabButton image boxPackStart innerBox lbl PackNatural 0 boxPackEnd innerBox tabButton PackNatural 0 containerAdd labelBox innerBox dragSourceSet labelBox [Button1] [ActionCopy,ActionMove] tl <- targetListNew targetListAddTextTargets tl 0 dragSourceSetTargetList labelBox tl on labelBox dragDataGet (\ cont id timeStamp -> do selectionDataSetText paneName return ()) return (tabButton,labelBox) cl <- runInIO closeHandler liftIO $ onClicked tb (cl ()) return lb where closeHandler :: PaneMonad alpha => () -> alpha () closeHandler _ = case groupPrefix `stripPrefix` paneName of Just group -> do closeGroup group Nothing -> do (PaneC pane) <- paneFromName paneName closePane pane return () groupLabel :: PaneMonad beta => String -> beta EventBox groupLabel group = do label <- liftIO $ labelNew Nothing liftIO $ labelSetUseMarkup label True liftIO $ labelSetMarkup label ("" ++ group ++ "") labelBox <- mkLabelBox label (groupPrefix ++ group) liftIO $ widgetShowAll labelBox return labelBox -- | Add the change mark or removes it markLabel :: (WidgetClass alpha, NotebookClass beta) => beta -> alpha -> Bool -> IO () markLabel nb topWidget modified = do mbBox <- notebookGetTabLabel nb topWidget case mbBox of Nothing -> return () Just box -> do mbContainer <- binGetChild (castToBin box) case mbContainer of Nothing -> return () Just container -> do children <- containerGetChildren container let label = castToLabel $ forceHead children "ViewFrame>>markLabel: empty children" text <- widgetGetName topWidget labelSetUseMarkup (castToLabel label) True labelSetMarkup (castToLabel label) (if modified then "" ++ text ++ "" else text) -- | Constructs a unique pane name, which is an index and a string figureOutPaneName :: PaneMonad alpha => String -> Int -> alpha (Int,String) figureOutPaneName bn ind = do bufs <- getPanesSt let ind = foldr (\(PaneC buf) ind -> if primPaneName buf == bn then max ind ((getAddedIndex buf) + 1) else ind) 0 (Map.elems bufs) if ind == 0 then return (0,bn) else return (ind,bn ++ "(" ++ show ind ++ ")") paneFromName :: PaneMonad alpha => PaneName -> alpha (IDEPane alpha) paneFromName pn = do mbPane <- mbPaneFromName pn case mbPane of Just p -> return p Nothing -> error $ "ViewFrame>>paneFromName:Can't find pane from unique name " ++ pn mbPaneFromName :: PaneMonad alpha => PaneName -> alpha (Maybe (IDEPane alpha)) mbPaneFromName pn = do panes <- getPanesSt return (Map.lookup pn panes) -- | guiPropertiesFromName :: PaneMonad alpha => PaneName -> alpha (PanePath, Connections) guiPropertiesFromName pn = do paneMap <- getPaneMapSt case Map.lookup pn paneMap of Just it -> return it otherwise -> error $"Cant't find guiProperties from unique name " ++ pn posTypeToPaneDirection PosLeft = LeftP posTypeToPaneDirection PosRight = RightP posTypeToPaneDirection PosTop = TopP posTypeToPaneDirection PosBottom = BottomP paneDirectionToPosType LeftP = PosLeft paneDirectionToPosType RightP = PosRight paneDirectionToPosType TopP = PosTop paneDirectionToPosType BottomP = PosBottom -- -- | Toggle the tabs of the current notebook -- viewSwitchTabs :: PaneMonad alpha => alpha () viewSwitchTabs = do mbNb <- getActiveNotebook case mbNb of Nothing -> return () Just nb -> liftIO $ do b <- notebookGetShowTabs nb notebookSetShowTabs nb (not b) -- -- | Sets the tab position in the current notebook -- viewTabsPos :: PaneMonad alpha => PositionType -> alpha () viewTabsPos pos = do mbNb <- getActiveNotebook case mbNb of Nothing -> return () Just nb -> liftIO $notebookSetTabPos nb pos -- -- | Split the currently active pane in horizontal direction -- viewSplitHorizontal :: PaneMonad alpha => alpha () viewSplitHorizontal = viewSplit Horizontal -- -- | Split the currently active pane in vertical direction -- viewSplitVertical :: PaneMonad alpha => alpha () viewSplitVertical = viewSplit Vertical -- -- | The active view can be split in two (horizontal or vertical) -- viewSplit :: PaneMonad alpha => Direction -> alpha () viewSplit dir = do mbPanePath <- getActivePanePath case mbPanePath of Nothing -> return () Just panePath -> do viewSplit' panePath dir viewSplit' :: PaneMonad alpha => PanePath -> Direction -> alpha () viewSplit' panePath dir = do l <- getLayout case layoutFromPath panePath l of (TerminalP _ _ _ (Just _) _) -> trace ("ViewFrame>>viewSplit': can't split detached: ") return () _ -> do activeNotebook <- (getNotebook' "viewSplit") panePath ind <- liftIO $ notebookGetCurrentPage activeNotebook mbPD <- do mbParent <- liftIO $ widgetGetParent activeNotebook case mbParent of Nothing -> trace ("ViewFrame>>viewSplit': parent not found: ") return Nothing Just parent -> do (nb,paneDir) <- do let (name,altname,paneDir, oldPath,newPath) = case dir of Horizontal -> ("top", "bottom", TopP, panePath ++ [SplitP TopP], panePath ++ [SplitP BottomP]) Vertical -> ("left", "right", LeftP, panePath ++ [SplitP LeftP], panePath ++ [SplitP RightP]) adjustNotebooks panePath oldPath frameState <- getFrameState setPanePathFromNB $ Map.insert activeNotebook oldPath (panePathFromNB frameState) nb <- newNotebook newPath (np,nbi) <- liftIO $ do newpane <- case dir of Horizontal -> do h <- vPanedNew return (castToPaned h) Vertical -> do v <- hPanedNew return (castToPaned v) rName <- widgetGetName activeNotebook widgetSetName newpane rName widgetSetName nb altname panedPack2 newpane nb True True nbIndex <- if parent `isA` gTypeNotebook then notebookPageNum ((castToNotebook' "viewSplit'1") parent) activeNotebook else trace ("ViewFrame>>viewSplit': parent not a notebook: ") return Nothing containerRemove (castToContainer parent) activeNotebook widgetSetName activeNotebook name panedPack1 newpane activeNotebook True True return (newpane,nbIndex) case (reverse panePath, nbi) of (SplitP dir:_, _) | dir `elem` [TopP, LeftP] -> liftIO $ panedPack1 (castToPaned parent) np True True | otherwise -> liftIO $ panedPack2 (castToPaned parent) np True True (GroupP group:_, Just n) -> do liftIO $ notebookInsertPage ((castToNotebook' "viewSplit' 2") parent) np group n label <- groupLabel group liftIO $ notebookSetTabLabel ((castToNotebook' "viewSplit' 3") parent) np label label2 <- groupMenuLabel group liftIO $ notebookSetMenuLabel ((castToNotebook' "viewSplit' 4") parent) np label2 return () ([], _) -> do liftIO $ boxPackStart (castToBox parent) np PackGrow 0 liftIO $ boxReorderChild (castToVBox parent) np 2 _ -> error "No notebook index found in viewSplit" liftIO $ do widgetShowAll np widgetGrabFocus activeNotebook case nbi of Just n -> do notebookSetCurrentPage ((castToNotebook' "viewSplit' 5") parent) n return () _ -> trace ("ViewFrame>>viewSplit': parent not a notebook2: ")return () return (nb,paneDir) handleFunc <- runInIO (handleNotebookSwitch nb) liftIO $ afterSwitchPage nb handleFunc return (Just (paneDir,dir)) case mbPD of Just (paneDir,pdir) -> do adjustPanes panePath (panePath ++ [SplitP paneDir]) adjustLayoutForSplit paneDir panePath mbWidget <- liftIO $ notebookGetNthPage activeNotebook ind when (isJust mbWidget) $ do name <- liftIO $ widgetGetName (fromJust mbWidget) mbPane <- mbPaneFromName name case mbPane of Just (PaneC pane) -> move (panePath ++ [SplitP (otherDirection paneDir)]) pane Nothing -> return () Nothing -> return () -- -- | Two notebooks can be collapsed to one -- viewCollapse :: PaneMonad alpha => alpha () viewCollapse = do mbPanePath <- getActivePanePath case mbPanePath of Nothing -> return () Just panePath -> do viewCollapse' panePath viewCollapse' :: PaneMonad alpha => PanePath -> alpha () viewCollapse' panePath = trace "viewCollapse' called" $ do layout1 <- getLayoutSt case layoutFromPath panePath layout1 of (TerminalP _ _ _ (Just _) _) -> trace ("ViewFrame>>viewCollapse': can't collapse detached: ") return () _ -> do let newPanePath = init panePath let mbOtherSidePath = otherSide panePath case mbOtherSidePath of Nothing -> trace ("ViewFrame>>viewCollapse': no other side path found: ") return () Just otherSidePath -> do nbop <- getNotebookOrPaned otherSidePath castToWidget let nb = if nbop `isA` gTypeNotebook then Just ((castToNotebook' "viewCollapse' 0") nbop) else Nothing case nb of Nothing -> trace ("ViewFrame>>viewCollapse': other side path not collapsedXX: ") $ case layoutFromPath otherSidePath layout1 of VerticalP _ _ _ -> do viewCollapse' (otherSidePath ++ [SplitP LeftP]) viewCollapse' panePath HorizontalP _ _ _ -> do viewCollapse' (otherSidePath ++ [SplitP TopP]) viewCollapse' panePath otherwise -> trace ("ViewFrame>>viewCollapse': impossible1 ") return () Just otherSideNotebook -> do paneMap <- getPaneMapSt activeNotebook <- (getNotebook' "viewCollapse' 1") panePath -- 1. Move panes and groups to one side (includes changes to paneMap and layout) let paneNamesToMove = map (\(w,(p,_)) -> w) $filter (\(w,(p,_)) -> otherSidePath == p) $Map.toList paneMap panesToMove <- mapM paneFromName paneNamesToMove mapM_ (\(PaneC p) -> move panePath p) panesToMove let groupNames = map (\n -> groupPrefix ++ n) $ getGroupsFrom otherSidePath layout1 mapM_ (\n -> move' (n,activeNotebook)) groupNames -- 2. Remove unused notebook from admin st <- getFrameState let ! newMap = Map.delete otherSideNotebook (panePathFromNB st) setPanePathFromNB newMap -- 3. Remove one level and reparent notebook mbParent <- liftIO $ widgetGetParent activeNotebook case mbParent of Nothing -> error "collapse: no parent" Just parent -> do mbGrandparent <- liftIO $ widgetGetParent parent case mbGrandparent of Nothing -> error "collapse: no grandparent" Just grandparent -> do nbIndex <- if grandparent `isA` gTypeNotebook then liftIO $ notebookPageNum ((castToNotebook' "viewCollapse'' 1") grandparent) parent else return Nothing liftIO $ containerRemove (castToContainer grandparent) parent liftIO $ containerRemove (castToContainer parent) activeNotebook if length panePath > 1 then do let lasPathElem = last newPanePath case (lasPathElem, nbIndex) of (SplitP dir, _) | dir == TopP || dir == LeftP -> liftIO $ panedPack1 (castToPaned grandparent) activeNotebook True True (SplitP dir, _) | dir == BottomP || dir == RightP -> liftIO $ panedPack2 (castToPaned grandparent) activeNotebook True True (GroupP group, Just n) -> do liftIO $ notebookInsertPage ((castToNotebook' "viewCollapse'' 2") grandparent) activeNotebook group n label <- groupLabel group liftIO $ do notebookSetTabLabel ((castToNotebook' "viewCollapse'' 3") grandparent) activeNotebook label notebookSetCurrentPage ((castToNotebook' "viewCollapse'' 4") grandparent) n return () _ -> error "collapse: Unable to find page index" liftIO $ widgetSetName activeNotebook $panePathElementToWidgetName lasPathElem else liftIO $ do boxPackStart (castToVBox grandparent) activeNotebook PackGrow 0 boxReorderChild (castToVBox grandparent) activeNotebook 2 widgetSetName activeNotebook "root" -- 4. Change panePathFromNotebook adjustNotebooks panePath newPanePath -- 5. Change paneMap adjustPanes panePath newPanePath -- 6. Change layout adjustLayoutForCollapse panePath getGroupsFrom :: PanePath -> PaneLayout -> [String] getGroupsFrom path layout = case layoutFromPath path layout of t@(TerminalP _ _ _ _ _) -> Map.keys (paneGroups t) HorizontalP _ _ _ -> [] VerticalP _ _ _ -> [] viewNewGroup :: PaneMonad alpha => alpha () viewNewGroup = do mainWindow <- getMainWindow mbGroupName <- liftIO $ groupNameDialog mainWindow case mbGroupName of Just groupName -> do layout <- getLayoutSt if groupName `Set.member` allGroupNames layout then liftIO $ do md <- messageDialogNew (Just mainWindow) [] MessageWarning ButtonsClose ("Group name not unique " ++ groupName) dialogRun md widgetDestroy md return () else viewNest groupName Nothing -> return () newGroupOrBringToFront :: PaneMonad alpha => String -> PanePath -> alpha (Maybe PanePath,Bool) newGroupOrBringToFront groupName pp = do layout <- getLayoutSt if groupName `Set.member` allGroupNames layout then do mbPP <- bringGroupToFront groupName return (mbPP,False) else let realPath = getBestPanePath pp layout in do viewNest' realPath groupName return (Just (realPath ++ [GroupP groupName]),True) bringGroupToFront :: PaneMonad alpha => String -> alpha (Maybe PanePath) bringGroupToFront groupName = do layout <- getLayoutSt case findGroupPath groupName layout of Just path -> do widget <- getNotebookOrPaned path castToWidget liftIO $ setCurrentNotebookPages widget return (Just path) Nothing -> return Nothing -- Yet another stupid little dialog groupNameDialog :: Window -> IO (Maybe String) groupNameDialog parent = liftIO $ do dia <- dialogNew windowSetTransientFor dia parent windowSetTitle dia "Enter group name" upper <- dialogGetUpper dia lower <- dialogGetActionArea dia (widget,inj,ext,_) <- buildEditor moduleFields "" (widget2,_,_,notifier) <- buildEditor okCancelFields () registerEvent notifier ButtonPressed (\e -> do case eventText 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 (const True) 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 Gtk.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) ltk-0.12.1.0/src/Graphics/UI/Editor/0000755000000000000000000000000011763167722015017 5ustar0000000000000000ltk-0.12.1.0/src/Graphics/UI/Editor/MakeEditor.hs0000644000000000000000000002241511763167722017403 0ustar0000000000000000----------------------------------------------------------------------------- --group_Test -- Module : Graphics.UI.Editor.MakeEditor -- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GNU-GPL -- -- Maintainer : -- Stability : provisional -- Portability : portable -- -- | Module for making editors out of descriptions -- ----------------------------------------------------------------------------------- module Graphics.UI.Editor.MakeEditor ( buildEditor , FieldDescription(..) , mkField , extractAndValidate , extract , mkEditor , parameters , flattenFieldDescription , getRealWidget , MkFieldDescription ) where import Graphics.UI.Gtk import Control.Monad import Data.List (intersperse, unzip4) import Control.Event import Graphics.UI.Editor.Parameters import Graphics.UI.Editor.Basics --import Graphics.UI.Frame.ViewFrame import Data.Maybe (isNothing) import Data.IORef (newIORef) import qualified Graphics.UI.Gtk.Gdk.Events as GTK (Event(..)) -- -- | 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 mapM_ (propagateEvent notifier notifiers) allGUIEvents let newExt = (\v -> extractAndValidate v getExts fieldNames notifier) mapM_ (\ (w,p) -> boxPackStart hb w p 0) $ zip widgets packParas 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) 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] -> Notifier -> IO (Maybe alpha) extractAndValidate val getExts fieldNames notifier = 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 triggerEvent notifier (GUIEvent { selector = ValidationError, gtkEvent = GTK.Event True, eventText = concat (intersperse ", " errors), gtkReturn = True}) 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) ltk-0.12.1.0/src/Graphics/UI/Editor/Parameters.hs0000644000000000000000000001422111763167722017456 0ustar0000000000000000----------------------------------------------------------------------------- -- -- Module : Graphics.UI.Editor.Parameters -- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GNU-GPL -- -- Maintainer : -- Stability : provisional -- Portability : portable -- -- | Module for parameters for editors -- ----------------------------------------------------------------------------------- module Graphics.UI.Editor.Parameters ( Parameters , Parameter(..) , paraName , paraSynopsis , paraDirection , paraShowLabel , paraShadow , paraOuterAlignment , paraInnerAlignment , paraOuterPadding , paraInnerPadding , paraMinSize , paraHorizontal , paraStockId , paraMultiSel , paraPack , getParameter , getParameterPrim , (<<<-) , emptyParams , Direction(..) , HorizontalAlign(..) ) where import Graphics.UI.Gtk import Data.Maybe import qualified Data.List as List -- -- | The direction of a split -- data Direction = Horizontal | Vertical deriving (Eq,Show) data HorizontalAlign = StartHorizontal | StopHorizontal | Keep deriving (Eq,Show) -- -- | A type for parameters for editors -- type Parameters = [Parameter] data Parameter = ParaName String | ParaSynopsis String | ParaDirection Direction | ParaShadow ShadowType | ParaShowLabel Bool | ParaOuterAlignment (Float,Float,Float,Float) -- | xalign yalign xscale yscale | ParaOuterPadding (Int,Int,Int,Int) -- | paddingTop paddingBottom paddingLeft paddingRight | ParaInnerAlignment (Float,Float,Float,Float) -- | xalign yalign xscale yscale | ParaInnerPadding (Int,Int,Int,Int) -- | paddingTop paddingBottom paddingLeft paddingRight | ParaMinSize (Int, Int) | ParaHorizontal HorizontalAlign | ParaStockId String | ParaMultiSel Bool | ParaPack Packing deriving (Eq,Show) {-- #if MIN_VERSION_gtk(0,9,13) -- now defined in gtk #else instance Show ShadowType where show _ = "Any Shadow" #endif --} emptyParams :: [Parameter] emptyParams = [] paraName :: (Parameter -> (Maybe String)) paraName (ParaName str) = Just str paraName _ = Nothing paraSynopsis :: (Parameter -> (Maybe String)) paraSynopsis (ParaSynopsis str) = Just str paraSynopsis _ = Nothing paraShowLabel :: (Parameter -> (Maybe Bool)) paraShowLabel (ParaShowLabel b) = Just b paraShowLabel _ = Nothing paraDirection :: (Parameter -> (Maybe Direction)) paraDirection (ParaDirection d) = Just d paraDirection _ = Nothing paraShadow :: (Parameter -> (Maybe ShadowType)) paraShadow (ParaShadow d) = Just d paraShadow _ = Nothing paraOuterAlignment :: (Parameter -> (Maybe (Float,Float,Float,Float))) paraOuterAlignment (ParaOuterAlignment d) = Just d paraOuterAlignment _ = Nothing paraInnerAlignment :: (Parameter -> (Maybe (Float,Float,Float,Float))) paraInnerAlignment (ParaInnerAlignment d) = Just d paraInnerAlignment _ = Nothing paraOuterPadding :: (Parameter -> (Maybe (Int,Int,Int,Int))) paraOuterPadding (ParaOuterPadding d) = Just d paraOuterPadding _ = Nothing paraInnerPadding :: (Parameter -> (Maybe (Int,Int,Int,Int))) paraInnerPadding (ParaInnerPadding d) = Just d paraInnerPadding _ = Nothing paraMinSize :: (Parameter -> (Maybe (Int, Int))) paraMinSize (ParaMinSize d) = Just d paraMinSize _ = Nothing paraHorizontal :: (Parameter -> (Maybe (HorizontalAlign))) paraHorizontal (ParaHorizontal d) = Just d paraHorizontal _ = Nothing paraStockId :: (Parameter -> (Maybe String)) paraStockId (ParaStockId str) = Just str paraStockId _ = Nothing paraMultiSel :: (Parameter -> (Maybe Bool)) paraMultiSel (ParaMultiSel b) = Just b paraMultiSel _ = Nothing paraPack :: (Parameter -> (Maybe Packing)) paraPack (ParaPack b) = Just b paraPack _ = Nothing -- -- | Convenience method to get a parameter, or if not set the default parameter -- getParameter :: (Parameter -> (Maybe beta)) -> Parameters -> beta getParameter selector parameter = case getParameterPrim selector parameter of Just ele -> ele _ -> case getParameterPrim selector defaultParameters of Just ele -> ele _ -> error "default parameter not defined" getParameterPrim :: (Parameter -> (Maybe beta)) -> Parameters -> Maybe beta getParameterPrim selector parameter = case filter isJust $ map selector parameter of (Just ele) : _ -> Just ele _ -> Nothing (<<<-) :: (Parameter -> (Maybe beta)) -> Parameter -> Parameters -> Parameters (<<<-) selector para params = para : filter (isNothing . selector) params defaultParameters :: Parameters defaultParameters = [ ParaName "" , ParaStockId "" , ParaSynopsis "" , ParaDirection Horizontal , ParaShadow ShadowNone , ParaOuterAlignment (0.4, 0.5, 1.0, 0.7) , ParaOuterPadding (5, 5, 5, 5) , ParaInnerAlignment (0.4, 0.5, 1.0, 0.7) , ParaInnerPadding (5, 5, 5, 5) , ParaMinSize (-1,-1) , ParaHorizontal Keep , ParaMultiSel True , ParaPack PackNatural , ParaShowLabel True ] ltk-0.12.1.0/src/Graphics/UI/Editor/DescriptionPP.hs0000644000000000000000000001062211763167722020077 0ustar0000000000000000----------------------------------------------------------------------------- -- -- Module : Graphics.UI.Editor.DescriptionPP -- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GNU-GPL -- -- Maintainer : -- Stability : provisional -- Portability : portable -- -- | Description of a editor with additional fileds for printing and parsing -- ----------------------------------------------------------------------------------- module Graphics.UI.Editor.DescriptionPP ( Applicator , FieldDescriptionPP(..) , mkFieldPP , extractFieldDescription , flattenFieldDescriptionPP , flattenFieldDescriptionPPToS ) where import Graphics.UI.Gtk import Control.Monad import qualified Text.PrettyPrint.HughesPJ as PP import qualified Text.ParserCombinators.Parsec as P import Text.PrinterParser hiding (fieldParser,parameters) import Graphics.UI.Editor.Parameters import Graphics.UI.Editor.MakeEditor --import IDE.Core.State import Graphics.UI.Editor.Basics (Applicator(..),Editor(..),Setter(..),Getter(..),Notifier(..),Extractor(..),Injector(..)) data FieldDescriptionPP alpha gamma = FDPP { parameters :: Parameters , fieldPrinter :: alpha -> PP.Doc , fieldParser :: alpha -> P.CharParser () alpha , fieldEditor :: alpha -> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier) , applicator :: alpha -> alpha -> gamma ()} | VFDPP Parameters [FieldDescriptionPP alpha gamma] | HFDPP Parameters [FieldDescriptionPP alpha gamma] | NFDPP [(String,FieldDescriptionPP alpha gamma)] type MkFieldDescriptionPP alpha beta gamma = Parameters -> (Printer beta) -> (Parser beta) -> (Getter alpha beta) -> (Setter alpha beta) -> (Editor beta) -> (Applicator beta gamma ) -> FieldDescriptionPP alpha gamma mkFieldPP :: (Eq beta, Monad gamma) => MkFieldDescriptionPP alpha beta gamma mkFieldPP parameters printer parser getter setter editor applicator = let FD _ ed = mkField parameters getter setter editor in FDPP parameters (\ dat -> (PP.text (case getParameterPrim paraName parameters of Nothing -> "" Just str -> str) PP.<> PP.colon) PP.$$ (PP.nest 15 (printer (getter dat))) PP.$$ (PP.nest 5 (case getParameterPrim paraSynopsis parameters of Nothing -> PP.empty Just str -> PP.text $"--" ++ str))) (\ dat -> P.try (do symbol (case getParameterPrim paraName parameters of Nothing -> "" Just str -> str) colon val <- parser return (setter val dat))) ed (\ newDat oldDat -> do --applicator let newField = getter newDat let oldField = getter oldDat if newField == oldField then return () else applicator newField) extractFieldDescription :: FieldDescriptionPP alpha gamma -> FieldDescription alpha extractFieldDescription (VFDPP paras descrs) = VFD paras (map extractFieldDescription descrs) extractFieldDescription (HFDPP paras descrs) = HFD paras (map extractFieldDescription descrs) extractFieldDescription (NFDPP descrsp) = NFD (map (\(s,d) -> (s, extractFieldDescription d)) descrsp) extractFieldDescription (FDPP parameters fieldPrinter fieldParser fieldEditor applicator) = (FD parameters fieldEditor) flattenFieldDescriptionPP :: FieldDescriptionPP alpha gamma -> [FieldDescriptionPP alpha gamma] flattenFieldDescriptionPP (VFDPP paras descrs) = concatMap flattenFieldDescriptionPP descrs flattenFieldDescriptionPP (HFDPP paras descrs) = concatMap flattenFieldDescriptionPP descrs flattenFieldDescriptionPP (NFDPP descrsp) = concatMap (flattenFieldDescriptionPP . snd) descrsp flattenFieldDescriptionPP fdpp = [fdpp] flattenFieldDescriptionPPToS :: FieldDescriptionPP alpha gamma -> [FieldDescriptionS alpha] flattenFieldDescriptionPPToS = map ppToS . flattenFieldDescriptionPP ppToS :: FieldDescriptionPP alpha gamma -> FieldDescriptionS alpha ppToS (FDPP para print pars _ _) = FDS para print pars ppToS _ = error "DescriptionPP.ppToS Can't transform" ltk-0.12.1.0/src/Graphics/UI/Editor/Simple.hs0000644000000000000000000010541411763167722016611 0ustar0000000000000000{-# OPTIONS_GHC -XScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : Graphics.UI.Editor.Simple -- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GNU-GPL -- -- Maintainer : -- Stability : provisional -- Portability : portable -- -- | Module for making simple editors -- ----------------------------------------------------------------------------------- module Graphics.UI.Editor.Simple ( noEditor , boolEditor , boolEditor2 , enumEditor , clickEditor , stringEditor , multilineStringEditor , intEditor , genericEditor , fontEditor , colorEditor , comboSelectionEditor , staticListEditor , staticListMultiEditor , multiselectionEditor , fileEditor , otherEditor , imageEditor , okCancelFields ) where #if MIN_VERSION_gtk(0,10,5) import Graphics.UI.Gtk hiding (eventKeyName, eventModifier) #else import Graphics.UI.Gtk #endif 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 #if MIN_VERSION_gtk(0,10,5) import Graphics.UI.Gtk.Gdk.Events (Event(..)) #else import Graphics.UI.Gtk.Gdk.Events (Event(..)) #endif import MyMissing (trim, allOf) import qualified Graphics.UI.Gtk.Gdk.Events as Gtk (Event(..)) import Unsafe.Coerce (unsafeCoerce) import Graphics.UI.Editor.Basics (GUIEvent(..), GUIEventSelector(..), propagateAsChanged, genericGUIEvents, activateEvent, Editor) -- ------------------------------------------------------------ -- * 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: genericGUIEvents) propagateAsChanged notifier [Clicked] 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:genericGUIEvents) mapM_ (activateEvent (castToWidget radio2) notifier Nothing) (Clicked:genericGUIEvents) propagateAsChanged notifier [Clicked] 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:genericGUIEvents) propagateAsChanged notifier [Clicked] 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 :: Bool -> Editor () clickEditor canDefault 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) when canDefault $ do set button [widgetCanDefault := True] widgetGrabDefault 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) -> Bool -> Editor String stringEditor validation trimBlanks 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) genericGUIEvents propagateAsChanged notifier [KeyPressed] containerAdd widget entry entrySetText entry (if trimBlanks then trim string else string) writeIORef coreRef (Just entry) Just entry -> entrySetText entry (if trimBlanks then trim string else string)) (do core <- readIORef coreRef case core of Nothing -> return Nothing Just entry -> do r <- entryGetText entry if validation r then return (Just (if trimBlanks then trim r else 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) genericGUIEvents propagateAsChanged notifier [KeyPressed] 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) (genericGUIEvents) activateEvent (castToWidget spin) notifier (Just (\ w h -> do res <- afterValueSpinned (castToSpinButton w) (do h (Gtk.Event True) return ()) return (unsafeCoerce res))) MayHaveChanged 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) 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:genericGUIEvents) 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) genericGUIEvents activateEvent (castToWidget combo) notifier (Just (\ w h -> do res <- on (castToComboBox w) changed (do h (Gtk.Event True) return ()) return (unsafeCoerce res))) MayHaveChanged 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) genericGUIEvents propagateAsChanged notifier [KeyPressed,ButtonPressed] 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) genericGUIEvents propagateAsChanged notifier [KeyPressed,ButtonPressed] 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) genericGUIEvents propagateAsChanged notifier [KeyPressed,ButtonPressed] 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) (Clicked:genericGUIEvents) entry <- entryNew widgetSetName entry $ getParameter paraName parameters ++ "-entry" -- set entry [ entryEditable := False ] mapM_ (activateEvent (castToWidget entry) notifier Nothing) genericGUIEvents registerEvent notifier Clicked (buttonHandler entry) propagateAsChanged notifier [KeyPressed,ButtonPressed] 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 fn triggerEvent notifier (GUIEvent { selector = MayHaveChanged, gtkEvent = Gtk.Event True, eventText = "", gtkReturn = True}) 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) (Clicked: genericGUIEvents) activateEvent (castToWidget fs) notifier (Just (\ w h -> do res <- onFontSet (castToFontButton w) (do h (Gtk.Event True) return ()) return (unsafeCoerce res))) MayHaveChanged 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) (Clicked: genericGUIEvents) activateEvent (castToWidget cs) notifier (Just (\ w h -> do res <- onColorSet (castToColorButton w) (do h (Gtk.Event True) return ()) return (unsafeCoerce res))) MayHaveChanged 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) (Clicked:genericGUIEvents) registerEvent notifier Clicked (buttonHandler coreRef) propagateAsChanged notifier [KeyPressed,ButtonPressed,Clicked] 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 stockCancel $ paraName <<<- ParaName "Cancel" $ emptyParams) (const ()) (\ _ b -> b) (clickEditor False) , mkField (paraStockId <<<- ParaStockId stockOk $ paraName <<<- ParaName "Ok" $ emptyParams) (const ()) (\ a b -> b) (clickEditor True)] ltk-0.12.1.0/src/Graphics/UI/Editor/Composite.hs0000644000000000000000000011715011763167722017322 0ustar0000000000000000----------------------------------------------------------------------------- -- -- Module : Graphics.UI.Editor.Composite -- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GNU-GPL -- -- Maintainer : -- Stability : provisional -- Portability : portable -- -- | Module for making composite editors -- ----------------------------------------------------------------------------------- module Graphics.UI.Editor.Composite ( maybeEditor , disableEditor , pairEditor , tupel3Editor , 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) import qualified Graphics.UI.Gtk.Gdk.Events as Gtk (Event(..)) import Unsafe.Coerce (unsafeCoerce) import Debug.Trace (trace) -- -- | 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 [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 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 [noti1,noti2,noti3]) (Clicked : 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 -- -- | 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 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 (onClickedHandler widget coreRef childRef cNoti) propagateEvent notifier [notifierBool] MayHaveChanged 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 (childWidget,inj2,ext2) <- getChildEditor childRef childEdit childParams cNoti children <- containerGetChildren vBox unless (elem childWidget children) $ 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 mapM_ (propagateEvent notifier [cNoti]) allGUIEvents 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 grayed out (if the positive Argument is False) -- disableEditor :: Default beta => (Editor beta, Parameters) -> Bool -> String -> Editor (Bool,beta) disableEditor (childEdit, childParams) positive boolLabel parameters notifier = do coreRef <- newIORef Nothing childRef <- newIORef Nothing notifierBool <- emptyNotifier cNoti <- emptyNotifier 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 (onClickedHandler widget coreRef childRef cNoti) propagateEvent notifier [notifierBool] MayHaveChanged case mbVal of (False,val) -> do (childWidget,inj2,ext2) <- getChildEditor childRef childEdit childParams cNoti boxPackEnd box childWidget PackGrow 0 widgetShowAll childWidget inj1 ( not positive) inj2 val widgetSetSensitive childWidget False (True,val) -> do (childWidget,inj2,ext2) <- getChildEditor childRef childEdit childParams cNoti boxPackEnd box childWidget PackGrow 0 widgetShowAll childWidget inj1 positive inj2 val widgetSetSensitive childWidget True writeIORef coreRef (Just (be,box)) Just (be@(boolFrame,inj1,extt),box) -> do hasChild <- hasChildEditor childRef case mbVal of (False,val) -> if hasChild then do (childWidget,_,_) <- getChildEditor childRef childEdit childParams cNoti inj1 (not positive) widgetSetSensitive childWidget False else inj1 (not positive) (True,val) -> if hasChild then do inj1 positive (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti inj2 val widgetSetSensitive childWidget True else do inj1 positive (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti boxPackEnd box childWidget PackGrow 0 widgetSetSensitive childWidget True 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 (True, value)) otherwise -> do (_,_,ext2) <- getChildEditor childRef childEdit childParams cNoti value <- ext2 case value of Nothing -> return Nothing Just value -> return (Just (False, value))) 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 widgetSetSensitive childWidget False else do hasChild <- hasChildEditor childRef if hasChild then do (childWidget,_,_) <- getChildEditor childRef childEdit childParams cNoti widgetSetSensitive childWidget True else do (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti boxPackEnd vBox childWidget PackNatural 0 inj2 getDefault widgetSetSensitive childWidget True 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 mapM_ (propagateEvent notifier [cNoti]) allGUIEvents 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 (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 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 mapM_ (propagateEvent notifier [cnoti]) allGUIEvents addButton <- buttonNewWithLabel "Add" removeButton <- buttonNewWithLabel "Remove" containerAdd buttonBox addButton containerAdd buttonBox removeButton listStore <- listStoreNew ([]:: [alpha]) activateEvent listStore notifier (Just (\ w h -> do res <- after (castToTreeModel w) rowInserted (\ _ _ -> h (Gtk.Event True) >> return ()) return (ConnectC res))) MayHaveChanged activateEvent listStore notifier (Just (\ w h -> do res <- after (castToTreeModel w) rowDeleted (\ _ -> h (Gtk.Event True) >> return ()) return (ConnectC res))) MayHaveChanged 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) -> Bool -> Editor [String] stringsEditor validation trimBlanks p = multisetEditor (ColumnDescr False [("",(\row -> [cellText := row]))]) (stringEditor validation trimBlanks, 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) 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)) True 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 ltk-0.12.1.0/src/Graphics/UI/Editor/Basics.hs0000644000000000000000000003050211763167722016557 0ustar0000000000000000{-# OPTIONS_GHC -XMultiParamTypeClasses -XScopedTypeVariables -XFlexibleContexts -XRankNTypes -XExistentialQuantification #-} ----------------------------------------------------------------------------- -- -- Module : Graphics.UI.Editor.Basics -- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GNU-GPL -- -- Maintainer : -- Stability : provisional -- Portability : portable -- -- | Module for the basiscs of composing GUIs from editors -- ----------------------------------------------------------------------------------- module Graphics.UI.Editor.Basics ( -- * Types Getter , Setter , Injector , Extractor , Applicator , Editor , getStandardRegFunction , emptyNotifier , GUIEvent(..) , GUIEventSelector(..) , GtkRegFunc , Notifier(..) , GtkHandler , Connection(..) , Connections , activateEvent , propagateEvent , allGUIEvents , genericGUIEvents , propagateAsChanged ) 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 , eventText :: 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 = FocusOut -- ^ generic, the widget looses the focus | FocusIn -- ^ generic, the widget gets the focus | ButtonPressed -- ^ generic, a mouse key has been pressed and released, while the widget has the focus | KeyPressed -- ^ generic, a keyboard key has been pressed and released, while the widget has the focus | Clicked -- ^ button specific, the button has been pressed | MayHaveChanged -- ^ generic, no gui event, the contents of the widget may have changed | ValidationError -- ^ validation of a contents has failed deriving (Eq,Ord,Show,Enum,Bounded) instance EventSelector GUIEventSelector allGUIEvents :: [GUIEventSelector] allGUIEvents = allOf genericGUIEvents = [FocusOut,FocusIn,ButtonPressed,KeyPressed] -- ------------------------------------------------------------ -- * 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 = forall o . GObjectClass o => o -> GtkHandler -> IO (Connection) -- -- | 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 = ([Connection], ([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 -- -- | Signal handlers for the different pane types -- data Connection = forall alpha . GObjectClass alpha => ConnectC (ConnectId alpha) type Connections = [Connection] 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 = 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,hand)] handlers Just l -> Map.insert eventSel ((unique,hand):l) handlers writeIORef pairRef (newHandlers,newGer) return (Just unique) unregisterEvent o@(Noti pairRef) eventSel 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) -> unregisterEvent es eventSel 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 () -- -- | 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 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 :: (GObjectClass o) => o -> Notifier -> Maybe (o -> GtkHandler -> IO Connection) -> 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 <- if (widget `isA` gTypeWidget) then widgetGetName (castToWidget widget) else return "no widget - no name" eventList <- mapM (\f -> do let ev = GUIEvent eventSel e "" 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 -> liftM ConnectC $ (castToWidget w) `onFocusOut` h getStandardRegFunction FocusIn = \w h -> liftM ConnectC $ (castToWidget w) `onFocusIn` h getStandardRegFunction ButtonPressed = \w h -> liftM ConnectC $ (castToWidget w) `afterButtonRelease` h getStandardRegFunction KeyPressed = \w h -> liftM ConnectC $ (castToWidget w) `afterKeyRelease` h getStandardRegFunction Clicked = \w h -> liftM ConnectC $ (castToButton w) `onClicked` (h (Gtk.Event True) >> return ()) getStandardRegFunction _ = error "Basic>>getStandardRegFunction: no original GUI event" registerEvents :: EventSource alpha beta gamma delta => alpha -> [delta] -> (beta -> gamma beta) -> gamma [Maybe Unique] registerEvents notifier selectors handler = mapM (\ s -> registerEvent notifier s handler) selectors propagateAsChanged :: (EventSource alpha GUIEvent m GUIEventSelector) => alpha -> [GUIEventSelector] -> m () propagateAsChanged notifier selectors = mapM_ (\s -> registerEvent notifier s (\ e -> triggerEvent notifier e{selector = MayHaveChanged})) selectors ltk-0.12.1.0/src/Control/0000755000000000000000000000000011763167722013134 5ustar0000000000000000ltk-0.12.1.0/src/Control/Event.hs0000644000000000000000000001006211763167722014550 0ustar0000000000000000{-# OPTIONS_GHC -XMultiParamTypeClasses -XFunctionalDependencies #-} ----------------------------------------------------------------------------- -- -- Module : Control.Event -- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GNU-GPL -- -- Maintainer : -- Stability : provisional -- Portability : portable -- -- | A simple event mechanism -- ------------------------------------------------------------------------------- module Control.Event ( EventSelector , Event(..) , EventSource(..) , Handlers , registerEvents ) where import Data.Map (Map) import qualified Data.Map as Map import Data.Unique import Control.Monad import Data.Maybe (catMaybes) -- | 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 -- alpha is the Notifier -- beta is the event -- gamma is the monad -- delta is the event selector 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 -- Args: Notifier, 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) -- returns Unique if registration was successfull, else Nothing -- Args: Notifier, EventSelector, Handler (Event -> Monad Event) registerEvent :: alpha -> delta -> (beta -> gamma beta) -> gamma (Maybe Unique) registerEvent o e 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 -- | use Left to register and Right to unregister -- Args: Notifier, EventSelector, Unique unregisterEvent :: alpha -> delta -> Unique -> gamma () unregisterEvent o e 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 () else error $ "Can't register event " ++ show e registerEvents :: EventSource alpha beta gamma delta => alpha -> [delta] -> (beta -> gamma beta) -> gamma [Unique] registerEvents o l handler = liftM catMaybes (mapM (\ e -> registerEvent o e handler) l) ltk-0.12.1.0/src/Text/0000755000000000000000000000000011763167722012440 5ustar0000000000000000ltk-0.12.1.0/src/Text/PrinterParser.hs0000644000000000000000000001506211763167722015600 0ustar0000000000000000{-# OPTIONS_GHC -XTypeSynonymInstances -XFlexibleInstances #-} -- -- | 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"