billeksah-forms (empty) → 1.0.0
raw patch · 16 files changed
+4113/−0 lines, 16 filesdep +Cabaldep +basedep +billeksah-panesetup-changed
Dependencies added: Cabal, base, billeksah-pane, billeksah-services, containers, directory, filepath, glib, gtk, mtl, parsec, pretty, transformers
Files
- LICENSE +165/−0
- Setup.lhs +6/−0
- billeksah-forms.cabal +51/−0
- src/Base/Preferences.hs +141/−0
- src/Graphics/Forms.hs +43/−0
- src/Graphics/Forms/Basics.hs +271/−0
- src/Graphics/Forms/Build.hs +341/−0
- src/Graphics/Forms/Composite.hs +725/−0
- src/Graphics/Forms/Default.hs +46/−0
- src/Graphics/Forms/Description.hs +221/−0
- src/Graphics/Forms/FormPane.hs +232/−0
- src/Graphics/Forms/GUIEvent.hs +225/−0
- src/Graphics/Forms/Parameters.hs +135/−0
- src/Graphics/Forms/Sets.hs +529/−0
- src/Graphics/Forms/Simple.hs +888/−0
- src/Graphics/Panes/Preferences.hs +94/−0
+ LICENSE view
@@ -0,0 +1,165 @@+ GNU LESSER GENERAL PUBLIC LICENSE+ Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.+++ This version of the GNU Lesser General Public License incorporates+the terms and conditions of version 3 of the GNU General Public+License, supplemented by the additional permissions listed below.++ 0. Additional Definitions.++ As used herein, "this License" refers to version 3 of the GNU Lesser+General Public License, and the "GNU GPL" refers to version 3 of the GNU+General Public License.++ "The Library" refers to a covered work governed by this License,+other than an Application or a Combined Work as defined below.++ An "Application" is any work that makes use of an interface provided+by the Library, but which is not otherwise based on the Library.+Defining a subclass of a class defined by the Library is deemed a mode+of using an interface provided by the Library.++ A "Combined Work" is a work produced by combining or linking an+Application with the Library. The particular version of the Library+with which the Combined Work was made is also called the "Linked+Version".++ The "Minimal Corresponding Source" for a Combined Work means the+Corresponding Source for the Combined Work, excluding any source code+for portions of the Combined Work that, considered in isolation, are+based on the Application, and not on the Linked Version.++ The "Corresponding Application Code" for a Combined Work means the+object code and/or source code for the Application, including any data+and utility programs needed for reproducing the Combined Work from the+Application, but excluding the System Libraries of the Combined Work.++ 1. Exception to Section 3 of the GNU GPL.++ You may convey a covered work under sections 3 and 4 of this License+without being bound by section 3 of the GNU GPL.++ 2. Conveying Modified Versions.++ If you modify a copy of the Library, and, in your modifications, a+facility refers to a function or data to be supplied by an Application+that uses the facility (other than as an argument passed when the+facility is invoked), then you may convey a copy of the modified+version:++ a) under this License, provided that you make a good faith effort to+ ensure that, in the event an Application does not supply the+ function or data, the facility still operates, and performs+ whatever part of its purpose remains meaningful, or++ b) under the GNU GPL, with none of the additional permissions of+ this License applicable to that copy.++ 3. Object Code Incorporating Material from Library Header Files.++ The object code form of an Application may incorporate material from+a header file that is part of the Library. You may convey such object+code under terms of your choice, provided that, if the incorporated+material is not limited to numerical parameters, data structure+layouts and accessors, or small macros, inline functions and templates+(ten or fewer lines in length), you do both of the following:++ a) Give prominent notice with each copy of the object code that the+ Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the object code with a copy of the GNU GPL and this license+ document.++ 4. Combined Works.++ You may convey a Combined Work under terms of your choice that,+taken together, effectively do not restrict modification of the+portions of the Library contained in the Combined Work and reverse+engineering for debugging such modifications, if you also do each of+the following:++ a) Give prominent notice with each copy of the Combined Work that+ the Library is used in it and that the Library and its use are+ covered by this License.++ b) Accompany the Combined Work with a copy of the GNU GPL and this license+ document.++ c) For a Combined Work that displays copyright notices during+ execution, include the copyright notice for the Library among+ these notices, as well as a reference directing the user to the+ copies of the GNU GPL and this license document.++ d) Do one of the following:++ 0) Convey the Minimal Corresponding Source under the terms of this+ License, and the Corresponding Application Code in a form+ suitable for, and under terms that permit, the user to+ recombine or relink the Application with a modified version of+ the Linked Version to produce a modified Combined Work, in the+ manner specified by section 6 of the GNU GPL for conveying+ Corresponding Source.++ 1) Use a suitable shared library mechanism for linking with the+ Library. A suitable mechanism is one that (a) uses at run time+ a copy of the Library already present on the user's computer+ system, and (b) will operate properly with a modified version+ of the Library that is interface-compatible with the Linked+ Version.++ e) Provide Installation Information, but only if you would otherwise+ be required to provide such information under section 6 of the+ GNU GPL, and only to the extent that such information is+ necessary to install and execute a modified version of the+ Combined Work produced by recombining or relinking the+ Application with a modified version of the Linked Version. (If+ you use option 4d0, the Installation Information must accompany+ the Minimal Corresponding Source and Corresponding Application+ Code. If you use option 4d1, you must provide the Installation+ Information in the manner specified by section 6 of the GNU GPL+ for conveying Corresponding Source.)++ 5. Combined Libraries.++ You may place library facilities that are a work based on the+Library side by side in a single library together with other library+facilities that are not Applications and are not covered by this+License, and convey such a combined library under terms of your+choice, if you do both of the following:++ a) Accompany the combined library with a copy of the same work based+ on the Library, uncombined with any other library facilities,+ conveyed under the terms of this License.++ b) Give prominent notice with the combined library that part of it+ is a work based on the Library, and explaining where to find the+ accompanying uncombined form of the same work.++ 6. Revised Versions of the GNU Lesser General Public License.++ The Free Software Foundation may publish revised and/or new versions+of the GNU Lesser 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+Library as you received it specifies that a certain numbered version+of the GNU Lesser General Public License "or any later version"+applies to it, you have the option of following the terms and+conditions either of that published version or of any later version+published by the Free Software Foundation. If the Library as you+received it does not specify a version number of the GNU Lesser+General Public License, you may choose any version of the GNU Lesser+General Public License ever published by the Free Software Foundation.++ If the Library as you received it specifies that a proxy can decide+whether future versions of the GNU Lesser General Public License shall+apply, that proxy's public statement of acceptance of any version is+permanent authorization for you to choose that version for the+Library.
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+
+ billeksah-forms.cabal view
@@ -0,0 +1,51 @@+name: billeksah-forms+version: 1.0.0+cabal-version: >= 1.8+build-type: Simple+license: LGPL+license-file: LICENSE+copyright: Juergen "jutaro" Nicklisch-Franken+maintainer: maintainer@leksah.org+homepage: http://www.leksah.org+package-url: https://github.com/leksah+bug-reports: http://code.google.com/p/leksah/issues/list+synopsis: Leksah library+description: Form library used by leksah to edit preferences, cabal infos, etc+category: Graphics+author: Juergen "jutaro" Nicklisch-Franken+tested-with: GHC ==7.0++Library+ exposed-modules:+ Graphics.Forms+ Graphics.Forms.Basics+ Graphics.Forms.Build+ Graphics.Forms.Composite+ Graphics.Forms.Sets+ Graphics.Forms.Default+ Graphics.Forms.Description+ Graphics.Forms.GUIEvent+ Graphics.Forms.Parameters+ Graphics.Forms.Simple+ Graphics.Forms.FormPane+ Base.Preferences+ Graphics.Panes.Preferences+ exposed: True+ buildable: True+ hs-source-dirs: src+ ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-unused-do-bind+ build-depends:+ base >=4.0.0.0 && <4.4,+ containers >=0.2 && <0.5,+ mtl >=1.1.0.2 && <2.1,+ transformers >= 0.2.2.0 && < 0.3,+ directory >= 1.1.0.0 && <1.2,+ filepath >= 1.2.0.0 && < 1.3,+ Cabal >= 1.10.1.0 && < 1.11,+ gtk >= 0.12.0 && < 0.13,+ glib >= 0.12.0 && < 0.13,+ parsec >= 3.1.1 && < 3.2,+ pretty >= 1.0.1.2 && < 1.1,++ billeksah-services >= 1.0.0 && < 1.1,+ billeksah-pane >= 1.0.0 && < 1.1
+ src/Base/Preferences.hs view
@@ -0,0 +1,141 @@+{-# Language ExistentialQuantification, TypeFamilies, DeriveDataTypeable #-}++-----------------------------------------------------------------------------+--+-- Module : Base.Preferences+-- Copyright : (c) Juergen Nicklisch-Franken+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+--+-- | Module for handling preferences+--+-----------------------------------------------------------------------------------++module Base.Preferences (+ loadPrefs+, savePrefs+, validatePrefs++, getPrefs+, setPrefs++) where++import Base+import Graphics.Pane++import Graphics.Forms.Parameters+import Graphics.Forms.Basics++import Data.List (sortBy, (\\), nub)+import Data.Typeable (Typeable(..), Typeable)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad (when)+import Graphics.UI.Gtk.General.Enums (ShadowType(..))+import qualified Text.PrettyPrint as PP (text)+import Graphics.Forms.Composite (pairEditor)+import Graphics.UI.Gtk (cellText)+import System.Glib.Attributes (AttrOp(..))+import Graphics.Forms.Simple (genericEditor, stringEditor)+import Debug.Trace (trace)++-------------------------------------+-- * The functions to handle preferences+--++++--+-- | Checks uniqness of categories+--+validatePrefs :: [(String,GenFieldDescription)] -> Maybe String+validatePrefs prefsDescr =+ let categories = map (\(cat,_) -> cat) prefsDescr+ nCats = nub categories+ in if nCats /= categories+ then Just $ "duplicate categories:" ++ show (categories \\ nCats)+ else Nothing++--+-- | Load preferences from filepath.+-- Pref descriptions needs to be registered before+loadPrefs :: FilePath -> StateM ()+loadPrefs fp = trace "loadPrefs" $ do+ allPrefs <- getState PrefsDescrState+ let allPrefsS = map (\(s,GenF descr val) -> (s, GenFS (toFieldDescriptionS descr) val)) allPrefs+ Left loadedPrefs <- liftIO $ readFields fp (Left allPrefsS)+ let newPrefs = map (exchangeValues loadedPrefs) allPrefs+ trace ("loadedPrefs " ++ show (length loadedPrefs)) $ setState PrefsDescrState newPrefs+ triggerFormsEvent PrefsChanged >> return ()+ where+ exchangeValues :: [(String, GenFieldDescriptionS)] -> (String, GenFieldDescription)+ -> (String, GenFieldDescription)+ exchangeValues loadedPrefs (s1, GenF fda a) =+ case [gen | (s2, gen) <- loadedPrefs, s1 == s2] of+ [GenFS _ newValue] -> let nv = myCast "Preferences>>loadPrefs:" newValue+ in (s1, GenF fda nv)+ _ -> (s1, GenF fda a)++--+-- | Save preferences to filepath.+-- Pref descriptions needs to be registered before.+savePrefs :: FilePath -> StateM ()+savePrefs fp = do+ allPrefs <- getState PrefsDescrState+ let allPrefsS = map (\(s,GenF fda a) -> (s, GenFS (toFieldDescriptionS fda) a)) allPrefs+ let string = showFields (Left allPrefsS)+ liftIO $ writeFile fp string+ triggerFormsEvent PrefsChanged >> return ()+++--+-- | Gets a preference value from a category+--+getPrefs :: Typeable alpha => String -> StateM alpha+getPrefs category = do+ allPrefs <- getState PrefsDescrState+ case [ genF | (s,genF) <- allPrefs, s == category] of+ [GenF _gd a] ->+ let a' = myCast ("Preferences>>getPrefs:" +++ "cast error for category: " ++ category) a+ in return a'+ _ -> error ("Preferences>>getPrefs: category not found: " ++ category)++--+-- | Sets a preference value for a category+--+setPrefs :: (Eq alpha , Typeable alpha) => String -> alpha -> StateM ()+setPrefs category value = do+ allPrefs <- getState PrefsDescrState+ setState PrefsDescrState+ (map (\ old@(s,GenF des a) ->+ if s == category+ then if typeOf a == typeOf value+ then (s,GenF des (myCast "setPrefs" value))+ else error ("Preferences>>setPrefs: type error for category: "+ ++ category)+ else old)+ allPrefs)+++-- -----------------------------------------------+-- * Convert to a form, which is usable for reading and writing to files+--+++toFieldDescriptionS :: FieldDescription alpha -> [FieldDescriptionS alpha]+toFieldDescriptionS = map ppToS . flattenFieldDescription+++ppToS :: FieldDescription alpha -> FieldDescriptionS alpha+ppToS (Field para print pars _ _) =+ FieldS (let ParaString str = getPara "Name" para in str) print pars+ (Just (let ParaString str = getPara "Synopsis" para in str))+ppToS _ = error "DescriptionPP.ppToS Can't transform"++flattenFieldDescription :: FieldDescription alpha -> [FieldDescription alpha]+flattenFieldDescription (VertBox _paras descrs) = concatMap flattenFieldDescription descrs+flattenFieldDescription (HoriBox _paras descrs) = concatMap flattenFieldDescription descrs+flattenFieldDescription (TabbedBox descrsp) = concatMap (flattenFieldDescription . snd) descrsp+flattenFieldDescription fdpp = [fdpp]
+ src/Graphics/Forms.hs view
@@ -0,0 +1,43 @@+-----------------------------------------------------------------------------+--+-- Module : Graphics.Forms+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- Stability : provisional+-- Portability : portable+--+-- |+--+-----------------------------------------------------------------------------------++module Graphics.Forms (+ module Graphics.Forms.Basics,+ module Graphics.Forms.Build,+ module Graphics.Forms.Composite,+ module Graphics.Forms.Sets,+ module Graphics.Forms.Default,+ module Graphics.Forms.Description,+ module Graphics.Forms.GUIEvent,+ module Graphics.Forms.Parameters,+ module Graphics.Forms.Simple,+ module Graphics.Forms.FormPane,+ module Base.Preferences,+ module Graphics.Panes.Preferences++) where++import Graphics.Forms.Basics+import Graphics.Forms.Build+import Graphics.Forms.Composite+import Graphics.Forms.Sets+import Graphics.Forms.Default+import Graphics.Forms.Description+import Graphics.Forms.GUIEvent+import Graphics.Forms.Parameters+import Graphics.Forms.Simple+import Graphics.Forms.FormPane+import Base.Preferences+import Graphics.Panes.Preferences+
+ src/Graphics/Forms/Basics.hs view
@@ -0,0 +1,271 @@+{-# Language MultiParamTypeClasses, ScopedTypeVariables, FlexibleContexts, RankNTypes,+ ExistentialQuantification, DeriveDataTypeable, TypeFamilies #-}++-----------------------------------------------------------------------------+--+-- Module : Graphics.Forms.Basics+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- Stability : provisional+-- Portability : portable+--+-- | Module for the basiscs of composing GUIs from editors+--+-----------------------------------------------------------------------------------++module Graphics.Forms.Basics (+-- * Types+ Getter+, Setter+, Injector+, Extractor+, Applicator+, Editor++, GUIEvent(..)+, GUIEventSelector(..)+, GEvent+, GenSelection(..)+, genericGUIEvents+, allGUIEvents++, pluginNameForms++, FieldDescription(..)+, GenFieldDescription(..)+, GenValue(..)+, castFD+, toGenFieldDescr+, toFieldEditor++, SectionName+, PrefsDescrState(..)++, FormsEvent(..)+, FormsEventSel(..)+, triggerFormsEvent+, getFormsEvent++, setCurrentPrefsPath+, getCurrentPrefsPath+, registerCurrentPrefsPath++) where+++import Base+import Graphics.Forms.Parameters++import Graphics.UI.Gtk+import qualified Graphics.UI.Gtk.Gdk.Events as Gtk+import Control.Monad+import Data.Typeable (Typeable(..), Typeable1, cast, Typeable)+import qualified Text.PrettyPrint as PP (Doc)+import qualified Text.ParserCombinators.Parsec as P (CharParser)+import Debug.Trace (trace)+import Data.Maybe (fromJust)++pluginNameForms :: [Char]+pluginNameForms = "billeksah-forms"+++-- ---------------------------------------------------------------------+-- * 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 -> StateM ()+--+-- | A type for extracting a value from an editor+--+type Extractor beta = StateM (Maybe beta)+--+-- | A type for the application of a value to be reflected in the GUI+--+type Applicator beta = beta -> StateM ()++--+-- | A type to describe an editor.+-- alpha is the type of the individual field of the record+type Editor alpha = Parameters -> GEvent -> StateM(Widget, Injector alpha , Extractor alpha)++type GEvent = EventChannel GUIEvent++--+-- | A type for an event in the GUI+--+data GUIEvent = GUIEvent {+ geSelector :: GUIEventSelector+, geGtkEvent :: Gtk.Event+, geText :: String+, geMbSelection :: Maybe GenSelection+, geGtkReturn :: Bool -- ^ True means that the event has been completely handled,+ -- gtk shoudn't do any further action about it (Often not+ -- a good idea+} deriving Typeable++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+ | Selection+ | Dummy+ deriving (Eq,Ord,Show,Bounded, Typeable, Enum)++instance Selector GUIEventSelector where+ type ValueType GUIEventSelector = EventChannel GUIEvent++data GenSelection = forall alpha . Typeable alpha => GenSelection alpha++allGUIEvents, genericGUIEvents :: [GUIEventSelector]+genericGUIEvents = [FocusOut,FocusIn,ButtonPressed,KeyPressed]+allGUIEvents = allOf++-- * A description for fields, that can be edited with a GUI+--+data FieldDescription alpha = Field {+ fdParameters :: Parameters+ , fdFieldPrinter :: alpha -> PP.Doc+ , fdFieldParser :: alpha -> P.CharParser () alpha+ , fdFieldEditor :: alpha -> StateM (Widget, Injector alpha , alpha -> Extractor alpha , GEvent)+ , fdApplicator :: alpha -> alpha -> StateM ()}+ | VertBox Parameters [FieldDescription alpha] -- ^ Vertical Box+ | HoriBox Parameters [FieldDescription alpha] -- ^ Horizontal Box+ | TabbedBox [(String,FieldDescription alpha)] -- ^ Notebook+ deriving (Typeable)++-- | A type neutral FieldDescription with a type neutral value attached+data GenFieldDescription = forall alpha . (Typeable alpha, Eq alpha) => GenF (FieldDescription alpha) alpha++-- | A type neutral value of a field description+data GenValue = forall alpha . (Typeable alpha, Eq alpha) => GenV alpha+ deriving Typeable++instance Eq GenValue where+ (GenV a) == (GenV b) = if typeOf a == typeOf b then+ fromJust (cast a) == b+ else False++toGenFieldDescr :: (Typeable alpha, Eq alpha) => FieldDescription alpha ->+ FieldDescription GenValue+toGenFieldDescr (VertBox paras fdl) = VertBox paras (map toGenFieldDescr fdl)+toGenFieldDescr (HoriBox paras fdl) = HoriBox paras (map toGenFieldDescr fdl)+toGenFieldDescr (TabbedBox list) = TabbedBox+ (map (\(s,fd) -> (s,toGenFieldDescr fd)) list)+toGenFieldDescr (Field paras fdFieldPrinter fdFieldParser fdFieldEditor fdApplicator)+ = trace (show paras) $ Field+ paras+ (\ (GenV a) ->+ let a' = myCast "Basics>>toGenFieldDescr:1 " a+ in fdFieldPrinter a')+ (\ (GenV a) ->+ let a' = myCast "Basics>>toGenFieldDescr:2 " a+ in liftM GenV (fdFieldParser a'))+ (\ (GenV a) ->+ let a' = myCast "Basics>>toGenFieldDescr:3 " a+ in liftM toFieldEditor (fdFieldEditor a'))+ (\ (GenV a) (GenV b) ->+ let (a', b') = (myCast "Basics>>toGenFieldDescr:4 " a,+ myCast "Basics>>toGenFieldDescr:5 " b)+ in fdApplicator a' b')++-- | A cast from a type neutral FieldDescription with a type neutral value+-- to a typed field description with a typed value+castFD :: (Typeable alpha, Typeable1 FieldDescription, Typeable GenValue) =>+ FieldDescription GenValue -> FieldDescription alpha+castFD fdGen = myCast "Basics>>castFD" fdGen+++toFieldEditor :: (Typeable alpha, Eq alpha) => (Widget,+ Injector alpha,+ alpha -> Extractor alpha,+ GEvent)+ -> (Widget,+ Injector GenValue,+ GenValue -> Extractor GenValue,+ GEvent)+toFieldEditor (widget, inj, ext, gevent) =+ (widget,+ (\ (GenV a) -> let a' = myCast "Basics>>toFieldEditor:1" a+ in inj a'),+ (\ (GenV a) -> let a' = myCast "Basics>>toFieldEditor:2" a+ in liftM genMaybe (ext a')),+ gevent)+ where+ genMaybe :: (Typeable alpha, Eq alpha) => Maybe alpha -> Maybe GenValue+ genMaybe Nothing = Nothing+ genMaybe (Just a) = Just (GenV a)++-- -----------------------------------------------+-- * Events the gui frame triggers+--++-- | The events of the forms plugin+data FormsEvent =+ RegisterPrefs [(String,GenFieldDescription)]+ -- ^ Callback to register perferences+ | PrefsChanged+ -- ^ The preferences have changed+ | NeedRestart+ -- ^ The application needs to be restarted to apply the changed preferences+ deriving Typeable++data FormsEventSel = FormsEventSel+ deriving (Eq, Ord, Show, Typeable)++instance Selector FormsEventSel where+ type ValueType FormsEventSel = EventChannel FormsEvent++triggerFormsEvent :: FormsEvent -> StateM (FormsEvent)+triggerFormsEvent = triggerEvent FormsEventSel++getFormsEvent :: StateM (EventChannel FormsEvent)+getFormsEvent = getEvent FormsEventSel++-------------------------------------+-- * Defining the state+--+++type SectionName = String++-- | The description and current value of preferences+data PrefsDescrState = PrefsDescrState+ deriving (Eq, Ord, Show, Typeable)++-- | The description and current value of preferences+instance Selector PrefsDescrState where+ type ValueType PrefsDescrState = [(SectionName,GenFieldDescription)]++-- | The file path for preferences+data PrefsPathSel = PrefsPathSel+ deriving (Eq,Ord,Show,Typeable)++-- | The file path for preferences+instance Selector PrefsPathSel where+ type ValueType PrefsPathSel = FilePath++setCurrentPrefsPath :: FilePath -> StateM ()+setCurrentPrefsPath = setState PrefsPathSel++getCurrentPrefsPath :: StateM FilePath+getCurrentPrefsPath = getState PrefsPathSel++registerCurrentPrefsPath :: FilePath -> StateM (Maybe String)+registerCurrentPrefsPath = registerState PrefsPathSel
+ src/Graphics/Forms/Build.hs view
@@ -0,0 +1,341 @@+{-# LANGUAGE ExistentialQuantification, DeriveDataTypeable, FlexibleContexts,+ ScopedTypeVariables #-}+-----------------------------------------------------------------------------+--+-- Module : Graphics.UI.Editor.MakeEditor+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- Stability : provisional+-- Portability : portable+--+-- | Module for making editors out of descriptions+--+-----------------------------------------------------------------------------------++module Graphics.Forms.Build (++ buildEditor+, buildGenericEditor++, FieldDescriptionG(..)+, toFieldDescriptionG+, GenFieldDescriptionG(..)+, castFDG+, mkFieldG++, extractAndValidate+, extract+, mkEditor+, parameters++, getRealWidget+, MkFieldDescriptionG+) where+++import Base+import Graphics.Pane hiding (newNotebook)++import Graphics.Forms.Parameters+import Graphics.Forms.Basics+import Graphics.Forms.GUIEvent++import Graphics.UI.Gtk+import Control.Monad+import Data.List (intersperse, unzip4)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Typeable (Typeable1, Typeable)+import Data.Maybe (fromJust, isJust)+++--+-- | A constructor type for a field desciption+--+type MkFieldDescriptionG alpha beta =+ String ->+ Parameters ->+ (Getter alpha beta) ->+ (Setter alpha beta) ->+ (Editor beta) ->+ FieldDescriptionG 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 FieldDescriptionG alpha = FieldG {+ fgParameters :: Parameters,+ fgFieldEditor :: alpha -> StateM (Widget, Injector alpha ,+ alpha -> Extractor alpha , GEvent)} -- Form+ | VertBoxG Parameters [FieldDescriptionG alpha] -- Vertical forms box+ | HoriBoxG Parameters [FieldDescriptionG alpha] -- Horizontal forms box+ | TabbedBoxG [(String,FieldDescriptionG alpha)] -- Notebook box+ deriving Typeable++-- | A type neutral FieldDescription with a type neutral value attached+data GenFieldDescriptionG = forall alpha . (Typeable alpha, Eq alpha) =>+ GenFG (FieldDescriptionG alpha) alpha++toFieldDescriptionG :: FieldDescription alpha -> FieldDescriptionG alpha+toFieldDescriptionG (VertBox paras descrs) =+ VertBoxG paras (map toFieldDescriptionG descrs)+toFieldDescriptionG (HoriBox paras descrs) =+ HoriBoxG paras (map toFieldDescriptionG descrs)+toFieldDescriptionG (TabbedBox descrsp) =+ TabbedBoxG (map (\(s,d) -> (s, toFieldDescriptionG d)) descrsp)+toFieldDescriptionG (Field parameters _ _ fieldEditor _) =+ (FieldG parameters fieldEditor)++toGenFieldDescrG :: (Typeable alpha, Eq alpha) => FieldDescriptionG alpha ->+ FieldDescriptionG GenValue+toGenFieldDescrG (VertBoxG paras fdl) = VertBoxG paras (map toGenFieldDescrG fdl)+toGenFieldDescrG (HoriBoxG paras fdl) = HoriBoxG paras (map toGenFieldDescrG fdl)+toGenFieldDescrG (TabbedBoxG list) = TabbedBoxG+ (map (\(s,fd) -> (s,toGenFieldDescrG fd)) list)+toGenFieldDescrG (FieldG paras fgFieldEditor)+ = FieldG+ paras+ (\ (GenV a) ->+ let a' = myCast "Basics>>toGenFieldDescrG " a+ in liftM toFieldEditor (fgFieldEditor a'))++-- | A cast from a type neutral FieldDescription with a type neutral value+-- to a typed field description with a typed value+castFDG :: (Typeable alpha, Typeable1 FieldDescription, Typeable GenValue) =>+ FieldDescriptionG GenValue -> FieldDescriptionG alpha+castFDG fdGen = myCast "Basics>>castFD:1 " fdGen++parameters :: FieldDescriptionG alpha -> Parameters+parameters (FieldG p _) = p+parameters (VertBoxG p _) = p+parameters (HoriBoxG p _) = p+parameters (TabbedBoxG _) = defaultParams+--+-- | 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++buildGenericEditor :: [(String,GenFieldDescriptionG)] ->+ StateM (Widget, Injector [GenValue] , [GenValue] -> Extractor [GenValue], GEvent)+buildGenericEditor pairList = buildEditorPrim pairList+ (mapM (\ (_,GenFG des val) ->+ buildEditor (toGenFieldDescrG des) (GenV val)) pairList)+ (\setInjs -> (\ v -> mapM_ (\ (ind,setInj) -> setInj (v!!ind))+ (zip [0..] setInjs)))+ (\ getExts -> (\ v -> liftM trans (mapM+ (\ (ind,exts) -> exts (v !! ind))+ (zip [0..] getExts))))+ where+ trans maybeList = if and (map isJust maybeList)+ then Just (map fromJust maybeList)+ else Nothing++buildEditor :: FieldDescriptionG alpha -> alpha ->+ StateM (Widget, Injector alpha , alpha -> Extractor alpha, GEvent)+buildEditor (FieldG _ editorf) v = editorf v+buildEditor (VertBoxG paras descrs) v = buildBoxEditor paras descrs Vertical v+buildEditor (HoriBoxG paras descrs) v = buildBoxEditor paras descrs Horizontal v+buildEditor (TabbedBoxG pairList) v = buildEditorPrim pairList+ (mapM (\d -> buildEditor d v) (map snd pairList))+ (\setInjs -> (\v -> mapM_ (\ setInj -> setInj v) setInjs))+ (\ getExts -> (\v -> extract v getExts))++buildEditorPrim+ :: (WidgetClass child) =>+ [(String, beta)]+ -> StateM [(child, Injector alpha, alpha -> Extractor alpha, EventChannel GUIEvent)]+ -> ([Injector alpha] -> Injector gamma)+ -> ([alpha -> Extractor alpha] -> gamma -> Extractor gamma)+ -> StateM (Widget, Injector gamma, gamma -> Extractor gamma, EventChannel GUIEvent)+buildEditorPrim pairList builder injector extractor = do+ reifyState $ \ stateR -> do+ nb <- newNotebook+ notebookSetShowTabs nb False+ resList <- reflectState builder stateR+ let (widgets, setInjs, getExts, notifiers) = unzip4 resList++ 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 = injector setInjs+ let newExt = extractor getExts+ notifier <- reflectState makeGUIEvent stateR+ reflectState (propagateEvent notifier notifiers) stateR+ return (castToWidget hb, newInj, newExt, notifier)+++buildBoxEditor :: Parameters -> [FieldDescriptionG alpha] -> Direction -> alpha+ -> StateM (Widget, Injector alpha , alpha -> Extractor alpha , GEvent)+buildBoxEditor paras descrs dir v = do+ resList <- mapM (\d -> buildEditor d v) descrs+ notifier <- makeGUIEvent+ let (widgets, setInjs, getExts, notifiers) = unzip4 resList+ case dir of+ Horizontal -> do+ let ParaBool hBoxHomogeneous = getPara "HBoxHomogeneous" paras+ b <- liftIO $ hBoxNew hBoxHomogeneous 0+ return (castToBox b)+ let newInj = (\v -> mapM_ (\ setInj -> setInj v) setInjs)+ let fieldNames = map (\fd -> getParaS "Name" (parameters fd)) descrs+ let packParas = map (\fd -> let ParaPack p = getPara "HPack" (parameters fd) in p) descrs+ propagateEvent notifier notifiers+ let newExt = (\v -> extractAndValidate v getExts fieldNames notifier)+ liftIO $ mapM_ (\ (w,p) -> boxPackStart b w p 0) $ zip widgets packParas+ return (castToWidget b, newInj, newExt, notifier)+ Vertical -> do+ let ParaBool vBoxHomogeneous = getPara "VBoxHomogeneous" paras+ b <- liftIO $ vBoxNew vBoxHomogeneous 0+ let newInj = (\v -> mapM_ (\ setInj -> setInj v) setInjs)+ let fieldNames = map (\fd -> getParaS "Name" (parameters fd)) descrs+ let packParas = map (\fd -> let ParaPack p = getPara "VPack" (parameters fd) in p) descrs+ propagateEvent notifier notifiers+ let newExt = (\v -> extractAndValidate v getExts fieldNames notifier)+ liftIO $ mapM_ (\ (w,p) -> boxPackStart b w p 0) $ zip widgets packParas+ return (castToWidget b, newInj, newExt, notifier)++--flattenFieldDescriptionG :: FieldDescriptionG alpha -> [FieldDescriptionG alpha]+--flattenFieldDescriptionG (VertBoxG _ descrs) = concatMap flattenFieldDescriptionG descrs+--flattenFieldDescriptionG (HoriBoxG _ descrs) = concatMap flattenFieldDescriptionG descrs+--flattenFieldDescriptionG (TabbedBoxG descrp) = concatMap (flattenFieldDescriptionG.snd) descrp+--flattenFieldDescriptionG fd = [fd]++-- ------------------------------------------------------------+-- * Implementation of editing+-- ------------------------------------------------------------++--+-- | Function to construct a field description+--+mkFieldG :: Eq beta => MkFieldDescriptionG alpha beta+mkFieldG name parameters getter setter editor =+ let realParas = ("Name", ParaString name) <<< parameters+ in FieldG realParas+ (\ dat -> do+ noti <- makeGUIEvent+ (widget,inj,ext) <- editor realParas 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 _ = liftIO $ do+ let ParaAlign (xalign, yalign, xscale, yscale) = getPara "OuterAlignment" parameters+ outerAlig <- alignmentNew xalign yalign xscale yscale+ let ParaPadding (paddingTop, paddingBottom, paddingLeft, paddingRight) = getPara "OuterPadding" parameters+ alignmentSetPadding outerAlig paddingTop paddingBottom paddingLeft paddingRight+ frame <- frameNew+ let ParaPos (x,y) = getPara "LabelAlign" parameters+ frameSetLabelAlign frame x y+ frameSetShadowType frame (let ParaShadow s = getPara "Shadow" parameters in s)+ case getParaS "Name" parameters of+ "" -> return ()+ str -> if getPara "ShowLabel" parameters == ParaBool True+ then frameSetLabel frame str+ else return ()+ case getParaS "Synopsis" parameters of+ "" -> return ()+ str -> set frame [widgetTooltipText := Just str]++ containerAdd outerAlig frame+ let ParaAlign (xalign, yalign, xscale, yscale) = getPara "InnerAlignment" parameters+ innerAlig <- alignmentNew xalign yalign xscale yscale+ let ParaPadding (paddingTop, paddingBottom, paddingLeft, paddingRight) = getPara "InnerPadding" parameters+ alignmentSetPadding innerAlig paddingTop paddingBottom paddingLeft paddingRight+ containerAdd frame innerAlig+ let ParaSize (x,y) = getPara "MinSize" parameters+ widgetSetSizeRequest outerAlig x y+ let name = getParaS "Name" parameters+ widgetSetName outerAlig name+ let ParaBool sens = getPara "Sensitivity" parameters+ widgetSetSensitivity innerAlig sens+ let build = injectorC (castToContainer innerAlig)+ return (castToWidget outerAlig, build, extractor)+++-- | Convenience method to validate and extract fields+--+extractAndValidate :: alpha -> [alpha -> Extractor alpha] -> [String] -> GEvent -> StateM (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+ triggerGUIEvent notifier (dummyGUIEvent {+ geSelector = ValidationError,+ geText = concat (intersperse ", " errors)})+ return Nothing++extract :: alpha -> [alpha -> Extractor alpha] -> StateM (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 -> StateM (Maybe Widget)+getRealWidget w = liftIO $ do+ mbF <- binGetChild (castToBin w)+ case mbF of+ Nothing -> return Nothing+ Just f -> do+ mbIA <- binGetChild (castToBin f)+ case mbIA of+ Nothing -> return Nothing+ Just iA -> binGetChild (castToBin iA)++++
+ src/Graphics/Forms/Composite.hs view
@@ -0,0 +1,725 @@+{-# Language ExistentialQuantification #-}+-----------------------------------------------------------------------------+--+-- Module : Graphics.Forms.Composite+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- Stability : provisional+-- Portability : portable+--+-- | Module for making composite editors+--+-----------------------------------------------------------------------------------++module Graphics.Forms.Composite (+ maybeEditor+, disableEditor+, pairEditor+, tupel3Editor+, splitEditor+, eitherOrEditor++, versionEditor+--, versionRangeEditor+--, dependencyEditor+--, dependenciesEditor+) where++import Graphics.Forms.Parameters+import Graphics.Forms.Basics+import Graphics.Forms.Build+import Graphics.Forms.Simple+import Graphics.Forms.GUIEvent+import Graphics.Forms.Default+import Base+import Graphics.Pane (Direction(..))++import Control.Monad.IO.Class(liftIO)+import Graphics.UI.Gtk+import Control.Monad+import Data.IORef+import Data.Maybe+import Distribution.Simple+ (PackageName(..))+import Distribution.Text (simpleParse, display)+import Data.Version (Version(..))+++--+-- | 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 <- liftIO $ newIORef Nothing+ noti1 <- makeGUIEvent+ noti2 <- makeGUIEvent+ propagateGUIEvent notifier [noti1,noti2] allGUIEvents+ fst@(fstFrame,inj1,_ext1) <- fstEd fstPara noti1+ snd@(sndFrame,inj2,_ext2) <- sndEd sndPara noti2+ mkEditor+ (\widget (v1,v2) -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ box <- case getPara "Direction" parameters of+ ParaDir Horizontal -> do+ b <- hBoxNew False 1+ return (castToBox b)+ ParaDir Vertical -> do+ b <- vBoxNew False 1+ return (castToBox b)+ _ -> error "Composite>>pairEditor"+ boxPackStart box fstFrame PackGrow 0+ boxPackStart box sndFrame PackGrow 0+ containerAdd widget box+ reflectState (do+ inj1 v1+ inj2 v2) stateR+ writeIORef coreRef (Just (fst,snd))+ Just ((_,inj1,_),(_,inj2,_)) -> do+ reflectState (do+ inj1 v1+ inj2 v2) stateR)+ (do+ core <- liftIO $ 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 <- liftIO $ newIORef Nothing+ noti1 <- makeGUIEvent+ noti2 <- makeGUIEvent+ noti3 <- makeGUIEvent+ propagateGUIEvent 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) -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ box <- case getPara "Direction" parameters of+ ParaDir Horizontal -> do+ b <- hBoxNew False 1+ return (castToBox b)+ ParaDir Vertical -> do+ b <- vBoxNew False 1+ return (castToBox b)+ _ -> error "Composite>>tupel3Editor"+ boxPackStart box frame1 PackGrow 0+ boxPackStart box frame2 PackGrow 0+ boxPackStart box frame3 PackGrow 0+ containerAdd widget box+ reflectState (do+ inj1 v1+ inj2 v2+ inj3 v3) stateR+ writeIORef coreRef (Just (r1,r2,r3))+ Just ((_,inj1,_),(_,inj2,_),(_,inj3,_)) -> do+ reflectState (do+ inj1 v1+ inj2 v2+ inj3 v3) stateR)+ (do core <- liftIO $ 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 <- liftIO $ newIORef Nothing+ noti1 <- makeGUIEvent+ noti2 <- makeGUIEvent+ propagateGUIEvent notifier [noti1,noti2] allGUIEvents+ fst@(fstFrame,inj1,_ext1) <- fstEd fstPara noti1+ snd@(sndFrame,inj2,_ext2) <- sndEd sndPara noti2+ mkEditor+ (\widget (v1,v2) -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ paned <- case getPara "Direction" parameters of+ ParaDir Horizontal -> do h <- vPanedNew+ return (castToPaned h)+ ParaDir Vertical -> do v <- hPanedNew+ return (castToPaned v)+ _ -> error "Composite>>splitEditor"+ panedPack1 paned fstFrame True True+ panedPack2 paned sndFrame True True+ containerAdd widget paned+ reflectState (do+ inj1 v1+ inj2 v2) stateR+ writeIORef coreRef (Just (fst,snd))+ Just ((_,inj1,_),(_,inj2,_)) -> do+ reflectState (do+ inj1 v1+ inj2 v2) stateR)+ (do+ core <- liftIO $ 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 <- liftIO $ newIORef Nothing+ childRef <- liftIO $ newIORef Nothing+ notifierBool <- makeGUIEvent+ cNoti <- makeGUIEvent+ mkEditor+ (\widget mbVal -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ box <- case getPara "Direction" parameters of+ ParaDir Horizontal -> do+ b <- hBoxNew False 1+ return (castToBox b)+ ParaDir Vertical -> do+ b <- vBoxNew False 1+ return (castToBox b)+ _ -> error "Composite>>maybeEditor"+ be@(boolFrame,inj1,_ext1) <- reflectState (boolEditor+ (("Name",ParaString boolLabel) <<< defaultParams)+ notifierBool) stateR+ boxPackStart box boolFrame PackNatural 0+ containerAdd widget box+ reflectState (do+ registerGUIEvent notifierBool [Clicked]+ (onClickedHandler widget coreRef childRef cNoti)+ propagateGUIEvent notifier [notifierBool] [MayHaveChanged]+ case mbVal of+ Nothing -> inj1 (not positive)+ Just val -> reifyState $ \ stateR -> do+ (childWidget,inj2,_ext2) <- reflectState(+ getChildEditor childRef childEdit childParams cNoti) stateR+ boxPackEnd box childWidget PackGrow 0+ widgetShowAll childWidget+ reflectState (do+ inj1 positive+ inj2 val) stateR) stateR+ writeIORef coreRef (Just (be,box))+ Just ((_boolFrame,inj1,_extt),box) -> do+ hasChild <- hasChildEditor childRef+ case mbVal of+ Nothing ->+ if hasChild+ then do+ (childWidget,_,_) <- reflectState(+ getChildEditor childRef childEdit childParams cNoti)+ stateR+ reflectState (inj1 (not positive)) stateR+ widgetHideAll childWidget+ else reflectState (inj1 (not positive)) stateR+ Just val ->+ if hasChild+ then do+ reflectState (inj1 positive) stateR+ (childWidget,inj2,_) <- reflectState (+ getChildEditor childRef childEdit childParams cNoti)+ stateR+ widgetShowAll childWidget+ reflectState (inj2 val) stateR+ else do+ reflectState (inj1 positive) stateR+ (childWidget,inj2,_) <- reflectState (+ getChildEditor childRef childEdit childParams cNoti)+ stateR+ boxPackEnd box childWidget PackGrow 0+ widgetShowAll childWidget+ reflectState (inj2 val) stateR)+ (reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> return Nothing+ Just ((_boolFrame,_inj1,ext1),_) -> do+ bool <- reflectState ext1 stateR+ case bool of+ Nothing -> return Nothing+ Just bv | bv == positive -> do+ (_,_,ext2) <- reflectState(+ getChildEditor childRef childEdit childParams cNoti) stateR+ value <- reflectState ext2 stateR+ case value of+ Nothing -> return Nothing+ Just value -> return (Just (Just value))+ _ -> return (Just Nothing))+ parameters+ notifier+ where+ onClickedHandler _widget coreRef childRef cNoti event = do+ core <- liftIO $ readIORef coreRef+ case core of+ Nothing -> error "Impossible"+ Just ((_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+ liftIO $ widgetHideAll childWidget+ else do+ _hasChild <- hasChildEditor childRef+ (childWidget,inj2,_ext2) <- getChildEditor childRef childEdit childParams cNoti+ children <- liftIO $ containerGetChildren vBox+ unless (elem childWidget children) $+ liftIO $ boxPackEnd vBox childWidget PackNatural 0+ inj2 getDefault+ liftIO $ widgetShowAll childWidget+ Nothing -> return ()+ return (event {geGtkReturn=True})+ getChildEditor childRef childEditor childParams cNoti = reifyState $ \ stateR -> do+ mb <- readIORef childRef+ case mb of+ Just editor -> return editor+ Nothing -> do+ let _val = childEditor+ editor@(_,_,_) <- reflectState (childEditor childParams cNoti) stateR+ reflectState (propagateGUIEvent notifier [cNoti] allGUIEvents) stateR+ writeIORef childRef (Just editor)+ return editor+ hasChildEditor childRef = liftIO $ 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 <- liftIO $ newIORef Nothing+ childRef <- liftIO $ newIORef Nothing+ notifierBool <- makeGUIEvent+ cNoti <- makeGUIEvent+ mkEditor+ (\widget mbVal -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ box <- case getPara "Direction" parameters of+ ParaDir Horizontal -> do+ b <- hBoxNew False 1+ return (castToBox b)+ ParaDir Vertical -> do+ b <- vBoxNew False 1+ return (castToBox b)+ _ -> error "Composite>>disableEditor"+ be@(boolFrame,inj1,_ext1) <- reflectState (boolEditor+ (("Name",ParaString boolLabel) <<< defaultParams)+ notifierBool) stateR+ boxPackStart box boolFrame PackNatural 0+ containerAdd widget box+ reflectState (do+ registerGUIEvent notifierBool [Clicked]+ (onClickedHandler widget coreRef childRef cNoti)+ propagateGUIEvent notifier [notifierBool] [MayHaveChanged]) stateR+ case mbVal of+ (False,val) -> do+ (childWidget,inj2,_ext2) <- reflectState (+ getChildEditor childRef childEdit childParams cNoti) stateR+ boxPackEnd box childWidget PackGrow 0+ widgetShowAll childWidget+ reflectState(do+ inj1 ( not positive)+ inj2 val) stateR+ widgetSetSensitive childWidget False+ (True,val) -> do+ (childWidget,inj2,_ext2) <- reflectState (+ getChildEditor childRef childEdit childParams cNoti) stateR+ boxPackEnd box childWidget PackGrow 0+ widgetShowAll childWidget+ reflectState(do+ inj1 positive+ inj2 val) stateR+ widgetSetSensitive childWidget True+ writeIORef coreRef (Just (be,box))+ Just ((_boolFrame,inj1,_extt),box) -> do+ hasChild <- hasChildEditor childRef+ case mbVal of+ (False,_val) ->+ if hasChild+ then do+ (childWidget,_,_) <- reflectState (+ getChildEditor childRef childEdit childParams cNoti)+ stateR+ reflectState (inj1 (not positive)) stateR+ widgetSetSensitive childWidget False+ else reflectState (inj1 (not positive)) stateR+ (True,val) ->+ if hasChild+ then do+ reflectState (inj1 positive) stateR+ (childWidget,inj2,_) <- reflectState (+ getChildEditor childRef childEdit childParams cNoti)+ stateR+ reflectState (inj2 val) stateR+ widgetSetSensitive childWidget True+ else do+ reflectState (inj1 positive) stateR+ (childWidget,inj2,_) <- reflectState (+ getChildEditor childRef childEdit childParams cNoti)+ stateR+ boxPackEnd box childWidget PackGrow 0+ widgetSetSensitive childWidget True+ reflectState (inj2 val) stateR)+ (do+ core <- liftIO $ readIORef coreRef+ case core of+ Nothing -> return Nothing+ Just ((_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))+ _ -> 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 <- liftIO $ readIORef coreRef+ case core of+ Nothing -> error "Impossible"+ Just ((_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+ liftIO $ widgetSetSensitive childWidget False+ else do+ hasChild <- hasChildEditor childRef+ if hasChild+ then do+ (childWidget,_,_) <- getChildEditor childRef childEdit childParams cNoti+ liftIO $ widgetSetSensitive childWidget True+ else do+ (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti+ liftIO $ boxPackEnd vBox childWidget PackNatural 0+ inj2 getDefault+ liftIO $ widgetSetSensitive childWidget True+ Nothing -> return ()+ return (event {geGtkReturn=True})+ getChildEditor childRef childEditor childParams cNoti = do+ mb <- liftIO $ readIORef childRef+ case mb of+ Just editor -> return editor+ Nothing -> do+ let _val = childEditor+ editor@(_,_,_) <- childEditor childParams cNoti+ propagateGUIEvent notifier [cNoti] allGUIEvents+ liftIO $ writeIORef childRef (Just editor)+ return editor+ hasChildEditor childRef = liftIO $ 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 <- liftIO $ newIORef Nothing+ noti1 <- makeGUIEvent+ noti2 <- makeGUIEvent+ noti3 <- makeGUIEvent+ propagateGUIEvent notifier [noti1,noti2,noti3] allGUIEvents+ be@(boolFrame,inj1,_ext1) <- boolEditor2 (getParaS "Name" rightParams) leftParams noti1+ le@(leftFrame,inj2,_ext2) <- leftEditor (("Name", ParaString "") <<< leftParams) noti2+ re@(rightFrame,inj3,_ext3) <- rightEditor (("Name", ParaString "") <<<rightParams) noti3+ mkEditor+ (\widget v -> do+ core <- liftIO $ readIORef coreRef+ case core of+ Nothing -> do+ registerGUIEvent noti1 [Clicked] (onClickedHandler widget coreRef)+ box <- case getPara "Direction" parameters of+ ParaDir Horizontal -> do+ b <- liftIO $ hBoxNew False 1+ return (castToBox b)+ ParaDir Vertical -> do+ b <- liftIO $ vBoxNew False 1+ return (castToBox b)+ _ -> error "Composite>>eitherOrEditor"+ liftIO $ boxPackStart box boolFrame PackNatural 0+ liftIO $ containerAdd widget box+ case v of+ Left vl -> do+ liftIO $ boxPackStart box leftFrame PackNatural 0+ inj2 vl+ inj3 getDefault+ inj1 True+ Right vr -> do+ liftIO $ boxPackStart box rightFrame PackNatural 0+ inj3 vr+ inj2 getDefault+ inj1 False+ liftIO $ writeIORef coreRef (Just (be,le,re,box))+ Just ((_,inj1,_),(leftFrame,inj2,_),(rightFrame,inj3,_),box) ->+ case v of+ Left vl -> do+ liftIO $ containerRemove box rightFrame+ liftIO $ boxPackStart box leftFrame PackNatural 0+ inj2 vl+ inj3 getDefault+ inj1 True+ Right vr -> do+ liftIO $ containerRemove box leftFrame+ liftIO $ boxPackStart box rightFrame PackNatural 0+ inj3 vr+ inj2 getDefault+ inj1 False)+ (do core <- liftIO $ 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)))+ (("Name",ParaString "") <<< parameters)+ notifier+ where+ onClickedHandler _widget coreRef event = do+ core <- liftIO $ readIORef coreRef+ case core of+ Nothing -> error "Impossible"+ Just ((_,_,ext1),(leftFrame,_,_),(rightFrame,_,_),box) -> do+ mbBool <- ext1+ case mbBool of+ Just bool ->+ if bool then liftIO $ do+ containerRemove box rightFrame+ boxPackStart box leftFrame PackNatural 0+ widgetShowAll box+ else liftIO $ do+ containerRemove box leftFrame+ boxPackStart box rightFrame PackNatural 0+ widgetShowAll box+ Nothing -> return ()+ return event{geGtkReturn=True}++++++--dependencyEditor :: [PackageIdentifier] -> Editor Dependency+--dependencyEditor packages para noti = do+-- (wid,inj,ext) <- pairEditor+-- ((eitherOrEditor (comboSelectionEditor ((sort . nub) (map (display . pkgName) packages)) id+-- , ("Name", ParaString "Select") <<< defaultParams)+-- (stringEditor (const True) True, ("Name", ParaString "Enter") <<< defaultParams)+-- "Select from list?"), ("Name", ParaString "Name") <<< defaultParams)+-- (versionRangeEditor,("Name", ParaString "Version") <<< defaultParams)+-- (("Direction", ParaDir 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],Nothing)+-- ,("Version",\(Dependency _ vers) ->+-- [cellText := display vers], Nothing)])+-- (dependencyEditor packages,+-- ("OuterAlignment",ParaAlign (0.0, 0.5, 1.0, 1.0)) <<<+-- (("InnerAlignment", ParaAlign (0.0, 0.5, 1.0, 1.0)) <<< defaultParams))+-- (Just (sortBy (\ (Dependency p1 _) (Dependency p2 _) -> compare p1 p2)))+-- (Just (\ (Dependency p1 _) (Dependency p2 _) -> p1 == p2))+-- (("Shadow", ParaShadow ShadowIn) <<<+-- ("OuterAlignment",ParaAlign (0.0, 0.5, 1.0, 1.0)) <<<+-- ("InnerAlignment", ParaAlign (0.0, 0.5, 1.0, 1.0)) <<<+-- ("Direction",ParaDir Vertical) <<<+-- ("VPack",ParaPack PackGrow) <<< p)+-- noti+--+--versionRangeEditor :: Editor VersionRange+--versionRangeEditor para noti = do+-- (wid,inj,ext) <-+-- maybeEditor+-- ((eitherOrEditor+-- (pairEditor+-- (comboSelectionEditor v1 show, defaultParams)+-- (versionEditor, ("Name",ParaString "Enter Version") <<< defaultParams),+-- (("Direction",ParaDir Vertical) <<<+-- ("Name",ParaString "Simple") <<<+-- ("OuterAlignment",ParaAlign (0.0, 0.0, 0.0, 0.0)) <<<+-- ("OuterPadding", ParaPadding (0, 0, 0, 0)) <<<+-- ("InnerAlignment", ParaAlign (0.0, 0.0, 0.0, 0.0)) <<<+-- ("InnerPadding", ParaPadding (0, 0, 0, 0)) <<< defaultParams))+-- (tupel3Editor+-- (comboSelectionEditor v2 show, defaultParams)+-- (versionRangeEditor, ("Shadow", ParaShadow ShadowIn) <<< defaultParams)+-- (versionRangeEditor, ("Shadow", ParaShadow ShadowIn) <<< defaultParams),+-- ("Name", ParaString "Complex") <<<+-- ("Direction", ParaDir Vertical) <<<+-- ("OuterAlignment", ParaAlign (0.0, 0.0, 0.0, 0.0)) <<<+-- ("OuterPadding", ParaPadding (0, 0, 0, 0)) <<<+-- ("InnerAlignment", ParaAlign (0.0, 0.0, 0.0, 0.0)) <<<+-- ("InnerPadding", ParaPadding (0, 0, 0, 0)) <<<defaultParams)+-- "Select version range"), defaultParams)+-- False "Any Version"+-- (("Direction", ParaDir 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++++++
+ src/Graphics/Forms/Default.hs view
@@ -0,0 +1,46 @@++-----------------------------------------------------------------------------+--+-- Module : Default+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info@leksah.org>+-- Stability : provisional+-- Portability : portable+--+-- | Module for default values of a data type+--+------------------------------------------------------------------------------++module Graphics.Forms.Default (+ Default(..)+) where++--+-- | A class for providing default values for certain types of editors+--+class Default alpha where+ getDefault :: alpha++instance Default Int where+ getDefault = 1++instance Default alpha => Default (Either alpha beta) where+ getDefault = Left getDefault++instance (Default alpha, Default beta) => Default (alpha, beta) where+ getDefault = (getDefault,getDefault)++instance (Default alpha, Default beta, Default gamma) => Default (alpha, beta, gamma) where+ getDefault = (getDefault,getDefault,getDefault)++instance Default [alpha] where+ getDefault = []++instance Default (Maybe alpha) where+ getDefault = Nothing++instance Default Bool where+ getDefault = True+
+ src/Graphics/Forms/Description.hs view
@@ -0,0 +1,221 @@+{-# Language EmptyDataDecls, DeriveDataTypeable, ExistentialQuantification,+ StandaloneDeriving, TypeFamilies #-}+-----------------------------------------------------------------------------+--+-- Module : Graphics.UI.Editor.DescriptionPP+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- Stability : provisional+-- Portability : portable+--+-- | Description of a editor with additional fileds for printing and parsing+--+-----------------------------------------------------------------------------------+module Graphics.Forms.Description (+ mkField+, formsPluginInterface+, initPrefs+) where++import Graphics.Forms.Basics+import Graphics.Forms.Parameters+import Graphics.Forms.Build+import Graphics.Forms.GUIEvent+import Graphics.Forms.Composite (pairEditor)+import Graphics.Forms.Simple (genericEditor, stringEditor)+import Graphics.Forms.Sets+import Graphics.Pane+import Base++import Graphics.UI.Gtk+import qualified Text.PrettyPrint.HughesPJ as PP+import qualified Text.ParserCombinators.Parsec as P+import Data.Version (Version(..))+import qualified Data.Map as Map (empty)+import Base.Preferences (loadPrefs, validatePrefs)+import Data.List (sortBy)+import Graphics.Panes.Preferences+ (PreferencesPane, openPreferencesPane)+import Control.Monad (liftM, when)+import System.FilePath ((</>), dropFileName)+import System.Directory (doesFileExist)+import Control.Monad.IO.Class (MonadIO(..))++-- ----------------------------------------------+-- * It's a plugin+--++formsPluginInterface :: StateM (PluginInterface FormsEvent)+formsPluginInterface = do+ fe <- makeEvent FormsEventSel+ return $ PluginInterface {+ piInit1 = formsInit1,+ piInit2 = formsInit2,+ piEvent = fe,+ piName = pluginNameForms,+ piVersion = Version [1,0,0][]}++-- -----------------------------------------------+-- * Initialization+--++formsInit1 :: BaseEvent -> EventChannel FormsEvent -> StateM ()+formsInit1 _baseEvent _myEvent = do+ message Debug ("init1 " ++ pluginNameForms)+ initialRegister+ return ()++formsInit2 :: BaseEvent -> EventChannel FormsEvent -> StateM ()+formsInit2 _baseEvent _myEvent = do+ message Debug ("init2 " ++ pluginNameForms)+ registerFrameEvent handler >> return ()+ where handler (RegisterActions actions) = return $ RegisterActions $ actions ++ myActions+ handler (RegisterPane paneTypes) = return $ RegisterPane $ paneTypes ++ myPaneTypes+ handler e = return e++myActions :: [ActionDescr]+myActions =+ [AD "Configuration" "_Configuration" Nothing Nothing (return ()) Nothing ActionSubmenu+ (Just $ MPAfter ["View"] False) Nothing [],+ AD "EditPrefs" "EditPrefs" Nothing Nothing openPreferencesPane Nothing ActionNormal+ (Just $ MPLast ["Configuration"] False) Nothing []]++myPaneTypes :: [(String,GenPane)]+myPaneTypes =+ [asRegisterType (undefined :: PreferencesPane)]++defaultPrefsName :: String+defaultPrefsName = "Default.prefs"++initialRegister :: StateM (Maybe String)+initialRegister = do+ registerState GuiHandlerStateSel (Handlers Map.empty)+ registerState GtkEventsStateSel (GtkRegMap Map.empty)+ registerState PrefsDescrState []+ currentConfigPath <- liftM dropFileName getCurrentConfigPath+ registerCurrentPrefsPath (currentConfigPath </> defaultPrefsName)++type MkFieldDescription alpha beta =+ Parameters ->+ (Printer beta) ->+ (Parser beta) ->+ (Getter alpha beta) ->+ (Setter alpha beta) ->+ (Editor beta) ->+ (Applicator beta) ->+ FieldDescription alpha++mkField :: Eq beta => MkFieldDescription alpha beta+mkField parameters printer parser getter setter editor applicator =+ let FieldG _ ed = mkFieldG (getParaS "Name" parameters) parameters getter setter editor+ in Field parameters+ (\ dat -> (PP.text (getParaS "Name" parameters) PP.<> PP.colon)+ PP.$$ (PP.nest 15 (printer (getter dat)))+ PP.$$ (PP.nest 5 (case getPara "Synopsis" parameters of+ ParaString "" -> PP.empty+ ParaString str -> PP.text $"--" ++ str+ _ -> error "Description>>mkField: impossible")))+ (\ dat -> P.try (do+ symbol (let ParaString str = getPara "Name" parameters in 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)++-- ----------------------------------------------+-- * Editing preferences+--++initPrefs :: StateM ()+initPrefs = do+ prefsPath <- getCurrentPrefsPath+ RegisterPrefs allPrefs <- triggerFormsEvent+ (RegisterPrefs [("Frame",GenF panesPrefs defaultPanePrefs)])+ liftIO $ putStrLn ("Categories: " ++ show (map fst allPrefs))+ case validatePrefs allPrefs of+ Nothing -> return ()+ Just str -> error $ "Description>>formsInit2::"++ str+ setState PrefsDescrState allPrefs+ hasPrefsFile <- liftIO $ doesFileExist prefsPath+ when hasPrefsFile $+ loadPrefs prefsPath++defaultPanePrefs :: PanePrefs+defaultPanePrefs = PanePrefs [] [] [SplitP LeftP]++panesPrefs :: FieldDescription PanePrefs+panesPrefs =+ VertBox defaultParams+ [mkField+ (("Name",ParaString "Categories for panes") <<<+ ("Shadow",ParaShadow ShadowIn) <<<+ ("Direction",ParaDir Vertical) <<<+ ("MinSize",ParaSize (-1,130)) <<<+ defaultParams)+ (PP.text . show)+ readParser+ (\ a -> ppCategoryForPane a)+ (\ b a -> a{ppCategoryForPane = b})+ (multisetEditor+ (ColumnsDescr True [+ ColumnDescr{+ tcdLabel = "Pane Id",+ tcdRenderer = cellRendererTextNew,+ tcdRenderFunc = \(n,_) -> [cellText := n],+ tcdMbEditFunc = Nothing},+ ColumnDescr{+ tcdLabel = "Pane category",+ tcdRenderer = cellRendererTextNew,+ tcdRenderFunc = \(_,v) -> [cellText := v],+ tcdMbEditFunc = Nothing}])+ ((pairEditor+ (stringEditor (\s -> not (null s)) True,defaultParams)+ (stringEditor (\s -> not (null s)) True,defaultParams)),defaultParams)+ (Just (sortBy (\(a,_) (a2,_) -> compare a a2)))+ (Just (\(a,_) (a2,_) -> a == a2)))+ (\_i -> return ())+ , mkField+ (("Name", ParaString "Pane path for category") <<<+ ("Shadow", ParaShadow ShadowIn) <<<+ ("Direction", ParaDir Vertical) <<<+ ("MinSize", ParaSize (-1,130)) <<<+ defaultParams)+ (PP.text . show)+ readParser+ ppPathForCategory+ (\b a -> a{ppPathForCategory = b})+ (multisetEditor+ (ColumnsDescr True [+ ColumnDescr{+ tcdLabel = "Pane category",+ tcdRenderer = cellRendererTextNew,+ tcdRenderFunc = \(n,_) -> [cellText := n],+ tcdMbEditFunc = Nothing},+ ColumnDescr{+ tcdLabel = "Pane path",+ tcdRenderer = cellRendererTextNew,+ tcdRenderFunc = \(_,v) -> [cellText := show v],+ tcdMbEditFunc = Nothing}])+ ((pairEditor+ (stringEditor (\s -> not (null s)) True,defaultParams)+ (genericEditor,defaultParams)),defaultParams)+ (Just (sortBy (\(a,_) (a2,_) -> compare a a2)))+ (Just (\(a,_) (a2,_) -> a == a2)))+ (\_i -> return ())+ , mkField+ (("Name", ParaString "Default pane path") <<< defaultParams)+ (PP.text . show)+ readParser+ ppDefaultPath+ (\b a -> a{ppDefaultPath = b})+ genericEditor+ (\_i -> return ())]+
+ src/Graphics/Forms/FormPane.hs view
@@ -0,0 +1,232 @@+{-# Language RankNTypes #-}+-----------------------------------------------------------------------------+--+-- Module : Graphics.Forms.FormPane+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- Stability : provisional+-- Portability : portable+--+-- | A standard builder for a pane with a form+--+-----------------------------------------------------------------------------------++module Graphics.Forms.FormPane (+ FormPaneDescr(..),+ buildFormsPane,+ buildGenericFormsPane,+ SimpleFormPaneDescr(..),+ buildSimpleFormsPane,+) where++import Base++import Graphics.Forms.Build+ (GenFieldDescriptionG(..), GenFieldDescriptionG,+ buildGenericEditor, FieldDescriptionG, buildEditor)+import Graphics.Forms.GUIEvent+ (registerGUIEvent, dummyGUIEvent, triggerGUIEvent)+import Graphics.Forms.Basics+ (GEvent, GenValue(..), Extractor, Injector, GUIEvent(..),+ GUIEventSelector(..))+import Graphics.Pane++import Graphics.UI.Gtk+import Control.Monad.IO.Class (MonadIO(..))+import Data.IORef (newIORef, readIORef, writeIORef)+import Control.Monad (when)+++-- | A description for a forms pane, which is targeted as an editor,+-- with save and cancel buttons++data FormPaneDescr alpha beta = FormPaneDescr {+ fpGetPane :: Pane beta => VBox -> Injector alpha -> Extractor alpha -> GEvent -> beta , -- ^ Construct the pane data type+ fpSaveAction :: alpha -> StateM (), -- ^ Called when the save button is hit+ fpHasChanged :: alpha -> alpha -> Bool, -- ^ Judge if this qualify as a change+ fpGuiHandlers :: [([GUIEventSelector],Handler GUIEvent)], -- ^ Handle GUI Events triggered+ fpExtraButtons :: [(String,StateM ())]} -- ^ Add extra buttons with handlers++--+-- | Returns a builder for a pane+-- Requires a forms description, an initial value and a FormPaneDescr+buildFormsPane :: Pane beta => FieldDescriptionG alpha -> alpha -> FormPaneDescr alpha beta+ -> (PanePath -> Notebook -> Window -> StateM (Maybe beta, Connections))+buildFormsPane descr val formDescr =+ buildFormsPanePrim descr (buildEditor descr val) formDescr val++--+-- | Returns a builder for a pane+-- Requires a forms description, an initial value and a FormPaneDescr+buildGenericFormsPane :: Pane beta => [(String,GenFieldDescriptionG)] -> FormPaneDescr [GenValue] beta+ -> (PanePath -> Notebook -> Window -> StateM (Maybe beta, Connections))+buildGenericFormsPane descr formDescr =+ buildFormsPanePrim descr (buildGenericEditor descr) formDescr+ (map (\ (_s,GenFG _ v) -> GenV v) descr)++-- | A description for a forms pane, which has no standard buttons and no change detection++data SimpleFormPaneDescr alpha beta = SimpleFormPaneDescr {+ sfpGetPane :: Pane beta => ScrolledWindow -> Injector alpha -> Extractor alpha -> GEvent -> beta}+ -- ^ Construct the pane data type++--+-- | Returns a builder for a pane+-- Requires a forms description, an initial value and a FormPaneDescr+buildSimpleFormsPane :: Pane beta => FieldDescriptionG alpha -> alpha -> SimpleFormPaneDescr alpha beta+ -> (PanePath -> Notebook -> Window -> StateM (Maybe beta, Connections))+buildSimpleFormsPane descr val formDescr =+ buildSimpleFormsPanePrim descr (buildEditor descr val) formDescr val+++buildFormsPanePrim+ :: (WidgetClass child, Pane a) =>+ t+ -> StateM+ (child,+ Injector alpha,+ alpha -> Extractor alpha,+ GEvent)+ -> FormPaneDescr alpha a+ -> alpha+ -> t1+ -> t2+ -> Window+ -> StateM (Maybe a, [ConnectId Widget])+buildFormsPanePrim _descr editor formDescr val = \ _panePath _notebook window -> do+ reifyState (\ stateR -> do+ ------------------------------------------+ -- Plugin editor+ lastSaved <- liftIO $ newIORef val+ (widget,inj,ext,notifier) <- reflectState editor stateR+ sw <- scrolledWindowNew Nothing Nothing+ scrolledWindowAddWithViewport sw widget+ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic++ -- Buttons+ bb <- hButtonBoxNew+ saveB <- buttonNewFromStock "gtk-save"+ revertB <- buttonNewFromStock "gtk-revert-to-saved"+ closeB <- buttonNewFromStock "gtk-close"++ extraButtons <- mapM buttonNewFromStock (map fst (fpExtraButtons formDescr))++ widgetSetSensitive saveB False+ widgetSetSensitive revertB False++ mapM (boxPackStartDefaults bb) extraButtons++ boxPackStartDefaults bb revertB+ boxPackStartDefaults bb saveB+ boxPackStartDefaults bb closeB++ validationLabel <- labelNew Nothing++ --Frame+ vb <- vBoxNew False 0+ boxPackStart vb sw PackGrow 7+ boxPackStart vb validationLabel PackNatural 0+ boxPackEnd vb bb PackNatural 7++ let inj2 = do+ (\b -> do+ liftIO $ writeIORef lastSaved b+ inj b)++ let pane = (fpGetPane formDescr) vb inj2 (ext val) notifier++ --Events+ cid1 <- saveB `onClicked` (do+ mbV <- reflectState (ext val) stateR+ case mbV of+ Nothing -> return ()+ Just v -> do+ reflectState (do+ (fpSaveAction formDescr) v+ liftIO $ writeIORef lastSaved v+ triggerGUIEvent notifier dummyGUIEvent{geSelector= MayHaveChanged}) stateR+ return ())++ cid2 <- revertB `onClicked` (do+ old <- readIORef lastSaved+ reflectState (inj old) stateR)++ cid3 <- closeB `onClicked` do+ (hasChanged',_) <- reflectState (hasChanged ext lastSaved) stateR+ if not hasChanged'+ then reflectState (closePane pane >> return ()) stateR+ else do+ md <- messageDialogNew (Just window) []+ MessageQuestion+ ButtonsYesNo+ "Unsaved changes. Close anyway?"+ set md [ windowWindowPosition := WinPosCenterOnParent ]+ resp <- dialogRun md+ widgetDestroy md+ case resp of+ ResponseYes -> do+ reflectState (closePane pane >> return ()) stateR+ _ -> return ()++ cids <- mapM (\ (button,handler) -> button `onClicked` (reflectState handler stateR))+ (zip extraButtons (map snd (fpExtraButtons formDescr)))++ reflectState (do+ registerGUIEvent notifier [MayHaveChanged] (\ e -> do+ (hasChanged',canExtract) <- hasChanged ext lastSaved+ when canExtract $ liftIO $ labelSetMarkup validationLabel ""+ setChanged pane hasChanged'+ liftIO $ widgetSetSensitive saveB hasChanged'+ liftIO $ widgetSetSensitive revertB hasChanged'+ return (e{geGtkReturn=False}))++ registerGUIEvent notifier [ValidationError] (\e -> do+ liftIO $ labelSetMarkup validationLabel+ ("<span foreground=\"red\" size=\"large\">" +++ "The following fields have invalid values: "+ ++ geText e ++ "</span>")+ return e)++ mapM_ (\ (selectors,handler) -> registerGUIEvent notifier selectors handler)+ (fpGuiHandlers formDescr)) stateR++ return (Just pane, map castCID ([cid1, cid2, cid3] ++ cids)))+ where+ hasChanged ext lastSavedRef = do+ old <- liftIO $ readIORef lastSavedRef+ mbP <- ext old+ return $ case mbP of+ Nothing -> (False,False)+ Just p -> (not ((fpHasChanged formDescr) p old), True)+++buildSimpleFormsPanePrim+ :: (WidgetClass child, Pane a) =>+ t+ -> StateM+ (child,+ Injector alpha,+ alpha -> Extractor alpha,+ GEvent)+ -> SimpleFormPaneDescr alpha a+ -> alpha+ -> t1+ -> t2+ -> Window+ -> StateM (Maybe a, [ConnectId Widget])+buildSimpleFormsPanePrim _descr editor formDescr val = \ _panePath _notebook _ -> do+ reifyState (\ stateR -> do+ ------------------------------------------+ (widget,inj,ext,notifier) <- reflectState editor stateR+ sw <- scrolledWindowNew Nothing Nothing+ scrolledWindowAddWithViewport sw widget+ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic++ --Frame++ let pane = (sfpGetPane formDescr) sw inj (ext val) notifier++ return (Just pane,[]))+ where
+ src/Graphics/Forms/GUIEvent.hs view
@@ -0,0 +1,225 @@+{-# Language MultiParamTypeClasses, ScopedTypeVariables, FlexibleContexts, RankNTypes,+ ExistentialQuantification, DeriveDataTypeable, StandaloneDeriving, TypeSynonymInstances,+ FlexibleInstances, TypeFamilies #-}++-----------------------------------------------------------------------------+--+-- Module : Graphics.Forms.GUIEvent+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- Stability : provisional+-- Portability : portable+--+-- | Module for handling gui events by our own event system+--+-----------------------------------------------------------------------------------++module Graphics.Forms.GUIEvent (++ getStandardRegFunction+, GtkRegFunc+, GtkHandler+, Connection+, Connections+, GtkRegMap(..)+, GuiHandlerStateSel(..)+, GtkEventsStateSel(..)++, activateGUIEvent+, activateGUIEvent'+, makeGUIEvent+, registerGUIEvent+, triggerGUIEvent+, propagateGUIEvent+, retriggerAsChanged+, dummyGUIEvent+) where++import Base+import Graphics.Pane+import Graphics.Forms.Basics+ (GUIEventSelector(..), GUIEvent(..), GEvent)++++import Graphics.UI.Gtk+import qualified Graphics.UI.Gtk.Gdk.Events as Gtk+import Data.Unique+import Control.Monad+import Data.Map (Map)+import qualified Data.Map as Map (insert,lookup,empty)+import Data.Typeable (Typeable)+++-- ------------------------------------------------------------+-- * 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.+-- The last map is used to unregister propagated events properly+--+type GUIEventReg = ([Connection],Map Unique [(Unique,GUIEvent)])++--+-- | The event state regarding to gtk+--+newtype GtkRegMap = GtkRegMap (Map EvtID (Map GUIEventSelector GUIEventReg))++data GuiHandlerStateSel = GuiHandlerStateSel+ deriving (Eq, Ord, Show, Typeable)++instance Selector GuiHandlerStateSel where+ type ValueType GuiHandlerStateSel = Handlers GUIEvent+++-- | All gui events share the same map+guiEventFactory :: EventFactory GUIEvent (Handlers GUIEvent)+guiEventFactory = EventFactory {+ efGetHandlers = getState GuiHandlerStateSel,+ efSetHandlers = setState GuiHandlerStateSel}++data GtkEventsStateSel = GtkEventsStateSel+ deriving (Eq, Ord, Show, Typeable)++instance Selector GtkEventsStateSel where+ type ValueType GtkEventsStateSel = GtkRegMap++--getGtkHandlers :: StateM GtkRegMap+--getGtkHandlers = getState GtkEventsStateSel+--+--setGtkHandlers :: GtkRegMap -> StateM ()+--setGtkHandlers = setState GtkEventsStateSel++withGtkHandlers :: (GtkRegMap -> GtkRegMap) -> StateM ()+withGtkHandlers = withState GtkEventsStateSel++--+-- | Constructs a new event. The plugin name has to be unique!+--+makeGUIEvent :: StateM (EventChannel GUIEvent)+makeGUIEvent = do+ let ef = guiEventFactory+ ev <- mkEvent (undefined :: GUIEventSelector) ef+ withState GuiHandlerStateSel (\ (Handlers handlerMap :: Handlers GUIEvent) ->+ case Map.lookup (evtID ev) handlerMap of+ Just _ -> error "Events>>makeGUIEvent: Event already known"+ Nothing -> Handlers (Map.insert (evtID ev) [] handlerMap))+ withGtkHandlers (addEventToGtkHandlers ev)+ return ev+ where+ addEventToGtkHandlers ev (GtkRegMap map) =+ case (evtID ev) `Map.lookup` map of+ Nothing -> GtkRegMap $ Map.insert (evtID ev) (Map.empty) map+ Just _ -> error "Events>>makeEvent: Unique not unique"++--+-- | Registers an event handler for this event+--+registerGUIEvent :: GEvent -> [GUIEventSelector] -> Handler GUIEvent -> StateM (HandlerID)+registerGUIEvent event selectors handler = registerEvent event guiEventHandler+ where+ guiEventHandler evt@GUIEvent{geSelector = sel}+ | elem sel selectors = handler evt+ | otherwise = return evt++propagateGUIEvent :: GEvent -> [GEvent] -> [GUIEventSelector] -> StateM ()+propagateGUIEvent to fromList selectors =+ mapM_ (\ from -> registerGUIEvent from selectors (\e -> (evtTrigger to) e)) fromList++-- TODO: unregister GUI events++triggerGUIEvent :: GEvent -> GUIEvent -> StateM GUIEvent+triggerGUIEvent event eventValue = (evtTrigger event) eventValue++dummyGUIEvent :: GUIEvent+dummyGUIEvent = GUIEvent{+ geSelector = Dummy,+ geGtkEvent = Gtk.Event True,+ geText = "",+ geMbSelection = Nothing,+ geGtkReturn = True}++--+-- | First register handlers, then activate the GUI event+activateGUIEvent+ :: (GObjectClass o) =>+ o+ -> EventChannel GUIEvent+ -> GUIEventSelector+ -> StateM ()+activateGUIEvent widget event eventSel = do+ activateGUIEvent' widget event (getStandardRegFunction eventSel) eventSel+++activateGUIEvent'+ :: (GObjectClass o) =>+ o+ -> EventChannel GUIEvent+ -> (o -> GtkHandler -> IO Connection)+ -> GUIEventSelector+ -> StateM ()+activateGUIEvent' widget event registerFunc eventSel = do+ cid <- reifyState $ \ stateR -> registerFunc widget (\ e -> do+ Handlers handlerMap <- reflectState (getState GuiHandlerStateSel) stateR+ case Map.lookup (evtID event) handlerMap of+ Nothing -> error "Events>>activateGUIEvent: Unknown event"+ Just [] -> return False+ Just handlers -> do+ name <- if (widget `isA` gTypeWidget)+ then widgetGetName (castToWidget widget)+ else return ""+ eventList <- mapM (\f -> let ev = GUIEvent+ {geSelector = eventSel,+ geGtkEvent = e,+ geText = name,+ geMbSelection = Nothing,+ geGtkReturn = False}+ in reflectState (f ev) stateR)+ (map snd handlers)+ let boolList = map geGtkReturn eventList+ return (foldr (&&) True boolList))+ withGtkHandlers (\ (GtkRegMap gtkHandlers) ->+ case Map.lookup (evtID event) gtkHandlers of+ Nothing -> error "Events>>activateGUIEvent: Unknown event"+ Just gtkMap ->+ GtkRegMap $ Map.insert (evtID event) (newGtkMap gtkMap cid) gtkHandlers)+ where+ newGtkMap gtkMap cid =+ case Map.lookup eventSel gtkMap of+ Nothing -> Map.insert eventSel ([cid],Map.empty) gtkMap+ Just (cids,prop) -> Map.insert eventSel (cid:cids,prop) gtkMap++--+-- | A convinence method for not repeating this over and over again+--+getStandardRegFunction :: GUIEventSelector -> GtkRegFunc+getStandardRegFunction FocusOut = \w h -> (castToWidget w) `onFocusOut` h+getStandardRegFunction FocusIn = \w h -> (castToWidget w) `onFocusIn` h+getStandardRegFunction ButtonPressed = \w h -> (castToWidget w) `onButtonPress` h+getStandardRegFunction KeyPressed = \w h -> (castToWidget w) `afterKeyRelease` h+getStandardRegFunction Clicked = \w h -> liftM castCID $ (castToButton w) `onClicked`+ (h (Gtk.Event True) >> return ())+getStandardRegFunction _ = error "Basic>>getStandardRegFunction: no original GUI event"++retriggerAsChanged :: GEvent -> [GUIEventSelector] -> StateM ()+retriggerAsChanged e selList =+ retriggerEvent e (\ ge@GUIEvent{geSelector = sel} ->+ if elem sel selList+ then Just ge{geSelector = MayHaveChanged}+ else Nothing )
+ src/Graphics/Forms/Parameters.hs view
@@ -0,0 +1,135 @@+{-# Language ExistentialQuantification, TypeFamilies, DeriveDataTypeable #-}++-----------------------------------------------------------------------------+--+-- Module : Graphics.Forms.Parameters+-- Copyright :+-- License : AllRightsReserved+--+-- Maintainer :+-- Stability :+-- Portability :+--+-- | Module for parameters for editors+-- Setting of parameters: ("Name", ParaString "Hello") `setPara` defaultParameters+-- Getting parameters getPara "Name" paras+--+-----------------------------------------------------------------------------++module Graphics.Forms.Parameters (+ defaultParams,+ (<<<),+ getPara,+ getParaS,+ ParaType(..),+ Parameters+) where++import Base+import Graphics.Pane++import Graphics.UI.Gtk (Packing, ShadowType)+import Graphics.UI.Gtk.General.Enums (Packing(..), ShadowType(..))+import Data.Typeable (Typeable)++-- ParaName "Hallo" <<< defaultParams+-- selector++-- setPara :: Selector alpha => alpha => (ValueType alpha) => Parameters -> Parameters++type Parameters = [Para ParaType]++-- type Parameters = forall alpha . (Selector alpha) [(alpha, ValueType alpha)]++++-- | A generalised attribute with independent get and set types.+data Para alpha = Para+ {paName :: String,+ paValue :: alpha}+ deriving Show++infixr 9 <<<++(<<<) :: (String, ParaType) -> Parameters -> Parameters+(<<<) (name,newValue) paras =+ case [ para | para <- paras, paName para == name] of+ [p] -> p{paValue = newValue} : [ para | para <- paras, paName para /= name]+ _ -> error $ "Parameters >> Cant find parameter " ++ name++getPara :: String -> Parameters -> ParaType+getPara name paras =+ case [ para | para <- paras, paName para == name] of+ [p] -> paValue p+ _ -> error $ "Parameters >> Cant find parameter " ++ name++getParaS :: String -> Parameters -> String+getParaS name paras = case getPara name paras of+ ParaString s -> s+ _ -> error "Parameters>>Not a string"++data StringSel = Name | StockId | Synopsis+ deriving (Eq, Ord, Show, Typeable)++instance Selector StringSel where+ type ValueType StringSel = String+++data ParaType =+ ParaString String+ | ParaAlign (Float,Float,Float,Float)+ | ParaPadding (Int,Int,Int,Int)+ | ParaSize (Int,Int)+ | ParaPos (Float,Float)+ | ParaBool Bool+ | ParaHori HorizontalAlign+ | ParaDir Direction+ | ParaShadow ShadowType+ | ParaPack Packing+ deriving(Eq,Show)++data HorizontalAlign = StartHorizontal | StopHorizontal | Keep+ deriving (Eq,Show)++--data StringPara = ParaName | ParaStockId | ParaSynopsis+-- deriving (Eq,Ord,Show,Typeable)+--+--instance Selector StringPara where+-- type ValueType = String+--+++defaultParams :: Parameters+defaultParams =+ [ Para "Name" (ParaString "")+ , Para "StockId" (ParaString "")+ , Para "Synopsis" (ParaString "")+ , Para "Sensitivity" (ParaBool True)+-- For boxes+ , Para "VBoxHomogeneous" (ParaBool False)+ , Para "HBoxHomogeneous" (ParaBool True)+ , Para "VPack" (ParaPack PackNatural)+ , Para "HPack" (ParaPack PackGrow)+-- For fields+ , Para "OuterAlignment" (ParaAlign (0.0, 0.0, 1, 1))+ , Para "OuterPadding" (ParaPadding (5, 5, 5, 5))+-- the label+ , Para "ShowLabel" (ParaBool True)+ , Para "LabelAlign" (ParaPos (0.5, 0.0))+ , Para "Shadow" (ParaShadow ShadowNone)+-- the inner alignment+ , Para "InnerAlignment" (ParaAlign (0.0, 0.0, 1, 1))+ , Para "InnerPadding" (ParaPadding (5, 5, 5, 5))++-- for the field+ , Para "MinSize" (ParaSize (-1,-1))++-- for special widgets+ , Para "Direction" (ParaDir Horizontal)+ , Para "MultiSel" (ParaBool True)+++-- , Para "Horizontal" (ParaHori Keep)+ ]++
+ src/Graphics/Forms/Sets.hs view
@@ -0,0 +1,529 @@+{-# Language ExistentialQuantification #-}+-----------------------------------------------------------------------------+--+-- Module : Graphics.Forms.Sets+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- Stability : provisional+-- Portability : portable+--+-- | Module for editors of sets of objects+--+-----------------------------------------------------------------------------------++module Graphics.Forms.Sets (+ ColumnsDescr(..),+ ColumnDescr(..),+ tableEditor,+ multisetEditor,+ selectionEditor,+ filesEditor,+ stringsEditor+) where++import Base+import Graphics.Panes+import Graphics.Pane (castCID)+import Graphics.Forms.Default (Default(..), Default)+import Graphics.Forms.Basics+import Graphics.Forms.Build (mkEditor)+import Graphics.Forms.Parameters+import Graphics.Forms.GUIEvent+import Graphics.Forms.Simple (stringEditor, fileEditor)+++import Graphics.UI.Gtk+import System.Glib.Attributes (AttrOp)+import Control.Monad.IO.Class (MonadIO(..))+import Data.IORef (writeIORef, readIORef, newIORef)+import Data.Typeable (Typeable)+import Control.Monad (liftM, when)+import Data.Maybe (isJust)+import qualified Graphics.UI.Gtk.Gdk.Events as Gtk (Event(..))+import Data.List (sort, elemIndex, sortBy, nubBy, nub)+import qualified Graphics.UI.Gtk as Gtk (Button)++-- | A Column decsription describes the colums for a table editor.+-- This is an example:+-- (ColumnsDescr True [+-- a simple column without editing+-- ColumnDescr{+-- tcdLabel = "Plugin",+-- tcdRenderer = cellRendererTextNew,+-- tcdRenderFunc = \ (pluginName',(_,_)) -> [cellText := pluginName'],+-- tcdMbEditFunc = Nothing},+-- with an editing function+-- ColumnDescr{+-- tcdLabel = "Lower",+-- tcdRenderer = cellRendererTextNew,+-- tcdRenderFunc = \ (_,(lower,_)) -> [cellText := showMbVersion lower],+-- tcdMbEditFunc = Just (\ renderer listStore notifier stateR -> do+-- set renderer [cellTextEditable := True]+-- on renderer edited (\ (p:_) str -> do+-- row@(pn,(lower,upper)) <- listStoreGetValue listStore p+-- let newRow = case parse boundParser "" str of+-- Left _ -> row+-- Right v -> (pn,(v,upper))+-- listStoreSetValue listStore p newRow+ -- reflectState (triggerGUIEvent notifier+ -- dummyGUIEvent {geSelector = MayHaveChanged}) stateR)+-- return ())},+++data ColumnsDescr alpha = ColumnsDescr {+ tcsdShowHeaders :: Bool,+ -- ^ describes, if headers should be shown+ tcsdColums :: [ColumnDescr alpha]}+ -- ^ describes the columns++data ColumnDescr alpha = forall beta . CellRendererClass beta => ColumnDescr {+ tcdLabel :: String,+ -- ^ the column header+ tcdRenderer :: IO beta,+ -- ^ construct the renderer used for this column+ tcdRenderFunc :: alpha -> [AttrOp beta],+ -- ^ the function to render the contest+ tcdMbEditFunc :: Maybe (beta -> ListStore alpha -> GEvent -> StateRef -> IO ())}+ -- ^ maybe a function, to edit the contest++--+-- | An editor for a list of given elements in the form of a table+--+tableEditor :: (Show alpha, Eq alpha) => ColumnsDescr alpha -> Editor [alpha]+tableEditor ColumnsDescr {tcsdShowHeaders = showHeaders, tcsdColums = columns} parameters notifier = do+ coreRef <- liftIO $ newIORef Nothing+ mkEditor+ (\widget table -> do+ core <- liftIO $ readIORef coreRef+ case core of+ Nothing -> do+ -- list store+ listStore <- liftIO $ listStoreNew ([]:: [alpha])++ reifyState $ \ stateR -> do+ -- tree view+ myTreeView <- treeViewNewWithModel listStore+ let ParaSize minSize = getPara "MinSize" parameters++ uncurry (widgetSetSizeRequest myTreeView) minSize+ sw1 <- scrolledWindowNew Nothing Nothing+ containerAdd sw1 myTreeView+ scrolledWindowSetPolicy sw1 PolicyAutomatic PolicyAutomatic+ mapM_ (\ tcd@ColumnDescr{tcdRenderer = rend, tcdMbEditFunc = mbEdit,+ tcdRenderFunc = renderFunc} -> do+ col <- treeViewColumnNew+ treeViewColumnSetTitle col (tcdLabel tcd)+ treeViewColumnSetResizable col True+ treeViewAppendColumn myTreeView col+ renderer <- rend+ case mbEdit of+ Nothing -> return ()+ Just func -> func renderer listStore notifier stateR+ cellLayoutPackStart col renderer True+ cellLayoutSetAttributes col renderer listStore renderFunc+ ) columns+ treeViewSetHeadersVisible myTreeView showHeaders++ containerAdd widget sw1++ fill table listStore+ writeIORef coreRef (Just listStore)+ Just listStore -> liftIO $ do+ fill table listStore)+ (liftIO $ do+ core <- readIORef coreRef+ case core of+ Nothing -> return Nothing+ Just listStore -> do+ v1 <- listStoreToList listStore+ return (Just v1))+ (("MinSize",ParaSize (-1,-1)) <<< parameters)+ notifier+ where+ fill table listStore = do+ listStoreClear listStore+ mapM_ (listStoreAppend listStore) table+++--+-- | An editor for a selection from some given elements+selectionEditor :: (Show alpha, Typeable alpha, Default alpha, Eq alpha) => ColumnsDescr alpha+ -> Maybe (alpha -> alpha -> Ordering) -- ^ The 'mbSort' arg, a sort function if desired+ -> Maybe (alpha -> alpha -> Bool) -- ^ the test to ommit double insertions+ -> Maybe ([alpha] -> StateM()) -- ^ a handler for elements, which gets deleted+ -> Editor ([alpha],[alpha])+selectionEditor ColumnsDescr{tcsdShowHeaders = showHeaders, tcsdColums = columns} mbSort mbTest+ mbDeleteHandler parameters notifier = do+ coreRef <- liftIO $ newIORef Nothing+ mkEditor+ (\ widget (selected,choices) -> do+ core <- liftIO $ readIORef coreRef+ case core of+ Nothing -> do+ (box,buttonBox) <- case getPara "Direction" parameters of+ ParaDir Horizontal -> do+ b <- liftIO $ hBoxNew False 1+ bb <- liftIO $ vButtonBoxNew+ return (castToBox b,castToButtonBox bb)+ ParaDir Vertical -> do+ b <- liftIO $ vBoxNew False 1+ bb <- liftIO $ hButtonBoxNew+ return (castToBox b,castToButtonBox bb)+ _ -> error "Composite>>selectionEditor"+ addButton <- liftIO $ buttonNewFromStock "gtk-add"+ removeButton <- liftIO $ buttonNewFromStock "gtk-remove"+ deleteButton <- liftIO $ buttonNewFromStock "gtk-delete"++ liftIO $ containerAdd buttonBox addButton+ when (isJust mbDeleteHandler) $ liftIO $ containerAdd buttonBox deleteButton+ liftIO $ containerAdd buttonBox removeButton++ -- Two list stores+ listStoreUnselected <- liftIO $ listStoreNew ([]:: [alpha])+ listStoreSelected <- liftIO $ listStoreNew ([]:: [alpha])++ activateGUIEvent' listStoreUnselected notifier+ (\ w h -> do+ res <- after (castToTreeModel w) rowInserted (\ _ _ ->+ h (Gtk.Event True) >> return ())+ return (castCID res)) MayHaveChanged+ activateGUIEvent' listStoreUnselected notifier+ (\ w h -> do+ res <- after (castToTreeModel w) rowDeleted (\ _ ->+ h (Gtk.Event True) >> return ())+ return (castCID res)) MayHaveChanged+ activateGUIEvent' listStoreSelected notifier+ (\ w h -> do+ res <- after (castToTreeModel w) rowInserted (\ _ _ ->+ h (Gtk.Event True) >> return ())+ return (castCID res)) MayHaveChanged+ activateGUIEvent' listStoreSelected notifier+ (\ w h -> do+ res <- after (castToTreeModel w) rowDeleted (\ _ ->+ h (Gtk.Event True) >> return ())+ return (castCID res)) MayHaveChanged+++ reifyState $ \ stateR -> do+ -- Two tree views+ treeViewSelected <- treeViewNewWithModel listStoreSelected+ let ParaSize minSize = getPara "MinSize" parameters++ uncurry (widgetSetSizeRequest treeViewSelected) minSize+ sw1 <- scrolledWindowNew Nothing Nothing+ containerAdd sw1 treeViewSelected+ scrolledWindowSetPolicy sw1 PolicyAutomatic PolicyAutomatic+ sel1 <- treeViewGetSelection treeViewSelected+ treeSelectionSetMode sel1 SelectionMultiple+ mapM_ (\ ColumnDescr{tcdLabel = label, tcdRenderer = rend,+ tcdRenderFunc = func, tcdMbEditFunc = mbFunc} -> do+ col <- treeViewColumnNew+ treeViewColumnSetTitle col label+ treeViewColumnSetResizable col True+ treeViewAppendColumn treeViewSelected col+ renderer <- rend+ case mbFunc of+ Nothing -> return ()+ Just efunc -> do+ efunc renderer listStoreSelected notifier stateR+ return ()+ cellLayoutPackStart col renderer True+ cellLayoutSetAttributes col renderer listStoreSelected func+ ) columns+ treeViewSetHeadersVisible treeViewSelected showHeaders+++ treeViewUnselected <- liftIO $ treeViewNewWithModel listStoreUnselected+ let ParaSize minSize = getPara "MinSize" parameters+ uncurry (widgetSetSizeRequest treeViewUnselected) minSize+ sw2 <- scrolledWindowNew Nothing Nothing+ containerAdd sw2 treeViewUnselected+ scrolledWindowSetPolicy sw2 PolicyAutomatic PolicyAutomatic+ sel2 <- treeViewGetSelection treeViewUnselected+ treeSelectionSetMode sel2 SelectionMultiple+ mapM_ (\ColumnDescr{tcdLabel = label, tcdRenderer = rend,+ tcdRenderFunc = func} -> do+ col <- treeViewColumnNew+ treeViewColumnSetTitle col label+ treeViewColumnSetResizable col True+ treeViewAppendColumn treeViewUnselected col+ renderer <- rend+ cellLayoutPackStart col renderer True+ cellLayoutSetAttributes col renderer listStoreUnselected func+ ) columns+ treeViewSetHeadersVisible treeViewSelected showHeaders++ boxPackStart box sw1 PackGrow 0+ boxPackStart box buttonBox PackNatural 0+ boxPackStart box sw2 PackNatural 0+ containerAdd widget box++ fill selected choices listStoreSelected listStoreUnselected+ reflectState (do+ activateGUIEvent treeViewSelected notifier ButtonPressed+ activateGUIEvent treeViewUnselected notifier ButtonPressed) stateR++ removeButton `onClicked` do+ treePaths <- treeSelectionGetSelectedRows sel1+ selected <- listStoreToList listStoreSelected+ unselected <- listStoreToList listStoreUnselected+ mapM_ (\(i:_) -> listStoreRemove listStoreSelected i) treePaths+ newSelected <- listStoreToList listStoreSelected+ fill newSelected (selected ++ unselected)+ listStoreSelected listStoreUnselected+ addButton `onClicked` do+ treePaths <- treeSelectionGetSelectedRows sel2+ selected <- listStoreToList listStoreSelected+ unselected <- listStoreToList listStoreUnselected+ addSelected <- mapM (\ (i:_) ->+ listStoreGetValue listStoreUnselected i) treePaths+ newSelected <- listStoreToList listStoreSelected+ fill (newSelected ++ addSelected) (selected ++ unselected)+ listStoreSelected listStoreUnselected+ case mbDeleteHandler of+ Just handler -> do+ deleteButton `onClicked` do+ treePaths <- treeSelectionGetSelectedRows sel2+ _unselected <- listStoreToList listStoreUnselected+ toDelete <- mapM (\(i:_) -> listStoreGetValue+ listStoreUnselected i)+ treePaths+ reflectState (handler toDelete) stateR+ return ()+ Nothing -> return ()++ doubleClickToSelected treeViewSelected sel1 listStoreSelected stateR+ doubleClickToSelected treeViewUnselected sel2 listStoreUnselected stateR+ writeIORef coreRef (Just (listStoreSelected,listStoreUnselected))+ Just (listStoreSelected,listStoreUnselected) -> liftIO $ do+ fill selected choices listStoreSelected listStoreUnselected)+ (liftIO $ do+ core <- readIORef coreRef+ case core of+ Nothing -> return Nothing+ Just (listStoreSelected,listStoreUnselected) -> do+ v1 <- listStoreToList listStoreSelected+ v2 <- listStoreToList listStoreUnselected+ return (Just (v1,v2)))+ (("MinSize",ParaSize (-1,-1)) <<< parameters)+ notifier+ where+ fill selected choices listStoreSelected listStoreUnselected =+ let selected' = case mbTest of+ Nothing -> nub selected+ Just f -> nubBy f selected+ all = selected ++ choices+ all' = case mbTest of+ Nothing -> nub all+ Just f -> nubBy f all+ unselected' = case mbTest of+ Nothing -> [e | e <- all' , not (elem e selected')]+ Just f -> [e | e <- all' ,+ null [ g | g <- selected', f g e]]+ in do+ listStoreClear listStoreSelected+ mapM_ (listStoreAppend listStoreSelected)+ (case mbSort of+ Nothing -> selected'+ Just sortF -> sortBy sortF selected')+ --Fill box 2+ listStoreClear listStoreUnselected+ mapM_ (listStoreAppend listStoreUnselected)+ (case mbSort of+ Nothing -> unselected'+ Just sortF -> sortBy sortF unselected')+ doubleClickToSelected treeView treeViewSelection listStore stateR =+ liftIO $ treeView `onButtonPress`+ (\ gtkEvent ->+ case gtkEvent of+ Gtk.Button{Gtk.eventClick = eventClick}+ | eventClick == DoubleClick -> do+ rows <- treeSelectionGetSelectedRows treeViewSelection+ mbVal <- case rows of+ ([i]:_) -> liftM (Just . GenSelection)+ (listStoreGetValue listStore i)+ _ -> return Nothing++ reflectState (triggerGUIEvent notifier (dummyGUIEvent {+ geSelector = Selection,+ geGtkEvent = gtkEvent,+ geMbSelection = mbVal,+ geGtkReturn = True})) stateR+ return False+ _ -> return False)++--+-- | An editor with a subeditor, of which a list of items can be selected+multisetEditor :: (Show alpha, Default alpha, Eq alpha) => ColumnsDescr 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 ColumnsDescr{tcsdShowHeaders = showHeaders, tcsdColums = columns}+ (singleEditor, sParams) mbSort mbReplace parameters notifier = do+ coreRef <- liftIO $ newIORef Nothing+ cnoti <- makeGUIEvent+ mkEditor+ (\widget vs -> do+ core <- liftIO $ readIORef coreRef+ case core of+ Nothing -> do+ (box,buttonBox) <- case getPara "Direction" parameters of+ ParaDir Horizontal -> do+ b <- liftIO $ hBoxNew False 1+ bb <- liftIO $ vButtonBoxNew+ return (castToBox b,castToButtonBox bb)+ ParaDir Vertical -> do+ b <- liftIO $ vBoxNew False 1+ bb <- liftIO $ hButtonBoxNew+ return (castToBox b,castToButtonBox bb)+ (frameS,injS,extS) <- singleEditor sParams cnoti+ propagateGUIEvent notifier [cnoti] allGUIEvents+ addButton <- liftIO $ buttonNewWithLabel "Add"+ removeButton <- liftIO $ buttonNewWithLabel "Remove"+ liftIO $ containerAdd buttonBox addButton+ liftIO $ containerAdd buttonBox removeButton+ listStore <- liftIO $ listStoreNew ([]:: [alpha])+ activateGUIEvent' listStore notifier+ (\ w h -> do+ res <- after (castToTreeModel w) rowInserted (\ _ _ ->+ h (Gtk.Event True) >> return ())+ return (castCID res)) MayHaveChanged+ activateGUIEvent' listStore notifier+ (\ w h -> do+ res <- after (castToTreeModel w) rowDeleted (\ _ ->+ h (Gtk.Event True) >> return ())+ return (castCID res)) MayHaveChanged+ treeView <- liftIO $ treeViewNewWithModel listStore+ let ParaSize minSize = getPara "MinSize" parameters+ reifyState $ \ stateR -> do+ uncurry (widgetSetSizeRequest treeView) minSize+ sw <- scrolledWindowNew Nothing Nothing+ containerAdd sw treeView+ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic+ sel <- treeViewGetSelection treeView+ treeSelectionSetMode sel SelectionSingle+ mapM_ (\ColumnDescr{tcdLabel = label, tcdRenderer = rend,+ tcdRenderFunc = func} -> do+ col <- treeViewColumnNew+ treeViewColumnSetTitle col label+ treeViewColumnSetResizable col True+ treeViewAppendColumn treeView col+ renderer <- rend++ cellLayoutPackStart col renderer True+ cellLayoutSetAttributes col renderer listStore func+ ) columns+ treeViewSetHeadersVisible treeView showHeaders+ sel `onSelectionChanged` selectionHandler sel listStore+ (\ a -> reflectState (injS a) stateR)+ boxPackStart box sw PackGrow 0+ boxPackStart box buttonBox PackNatural 0+ boxPackStart box frameS PackNatural 0+ reflectState (activateGUIEvent (castToWidget treeView) notifier FocusOut)+ stateR+ containerAdd widget box+ listStoreClear listStore+ mapM_ (listStoreAppend listStore)+ (case mbSort of+ Nothing -> vs+ Just sortF -> sortF vs)+ addButton `onClicked` do+ mbv <- reflectState extS stateR+ 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)+ reflectState (injS getDefault) stateR+ Just listStore -> liftIO $ do+ listStoreClear listStore+ mapM_ (listStoreAppend listStore)+ (case mbSort of+ Nothing -> vs+ Just sortF -> sortF vs))+ (liftIO $ do+ core <- readIORef coreRef+ case core of+ Nothing -> return Nothing+ Just listStore -> do+ v <- listStoreToList listStore+ return (Just v))+ (("MinSize",ParaSize (-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+ (ColumnsDescr False [+ ColumnDescr{+ tcdLabel = "",+ tcdRenderer = cellRendererTextNew,+ tcdRenderFunc = \row -> [cellText := row],+ tcdMbEditFunc = Nothing}])+ (fileEditor fp act label, defaultParams)+ (Just sort)+ (Just (==))+ (("Shadow", ParaShadow ShadowIn) <<<+ (("Direction", ParaDir Vertical) <<< p))++stringsEditor :: (String -> Bool) -> Bool -> Editor [String]+stringsEditor validation trimBlanks p =+ multisetEditor+ (ColumnsDescr False [+ ColumnDescr{+ tcdLabel = "",+ tcdRenderer = cellRendererTextNew,+ tcdRenderFunc = \row -> [cellText := row],+ tcdMbEditFunc = Nothing}])+ (stringEditor validation trimBlanks, defaultParams)+ (Just sort)+ (Just (==))+ (("Shadow", ParaShadow ShadowIn) <<< p)+
+ src/Graphics/Forms/Simple.hs view
@@ -0,0 +1,888 @@+{-# Language ScopedTypeVariables, CPP #-}+-----------------------------------------------------------------------------+--+-- Module : Graphics.Forms.Simple+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- Stability : provisional+-- Portability : portable+--+-- | Module for making simple editors+--+-----------------------------------------------------------------------------------++module Graphics.Forms.Simple (+ noEditor+, boolEditor+, boolEditor2+, buttonEditor+, dummyGetter+, dummySetter+, enumEditor+, clickEditor+, stringEditor+, multilineStringEditor+, intEditor+, genericEditor+, fontEditor+, colorEditor+, comboSelectionEditor+, staticListEditor+, staticListMultiEditor+, multiselectionEditor+, fileEditor+, otherEditor+, imageEditor++) where+++import Base+import Graphics.Pane++import Graphics.Forms.Basics+import Graphics.Forms.Parameters+import Graphics.Forms.Build+import Graphics.Forms.GUIEvent++import Graphics.UI.Gtk hiding (eventKeyName, eventModifier)+import Control.Monad+import Control.Monad.IO.Class+import Data.IORef+import Data.List+import Graphics.UI.Gtk.Gdk.Events (Event(..))+import qualified Graphics.UI.Gtk.Gdk.Events as Gtk (Event(..))+import Unsafe.Coerce (unsafeCoerce)+import Control.Exception (SomeException)+++-- ------------------------------------------------------------+-- * 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+ (\ _ _ -> 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 <- liftIO $ newIORef Nothing+ mkEditor+ (\widget bool -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ button <- checkButtonNewWithLabel (getParaS "Name" parameters)+ widgetSetName button (getParaS "Name" parameters)+ containerAdd widget button+ toggleButtonSetActive button bool+ reflectState (do+ mapM_ (activateGUIEvent (castToWidget button) notifier)+ (Clicked: genericGUIEvents)+ retriggerAsChanged notifier [Clicked]) stateR+ writeIORef coreRef (Just button)+ Just button -> toggleButtonSetActive button bool)+ (liftIO $ do+ core <- readIORef coreRef+ case core of+ Nothing -> return Nothing+ Just button -> do+ r <- toggleButtonGetActive button+ return (Just r))+ (("Name",ParaString "") <<< parameters)+ notifier++--+-- | Editor for a boolean value in the form of two radio buttons+----+boolEditor2 :: String -> Editor Bool+boolEditor2 label2 parameters notifier = do+ coreRef <- liftIO $ newIORef Nothing+ mkEditor+ (\widget bool -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ box <- vBoxNew True 2+ radio1 <- radioButtonNewWithLabel (getParaS "Name" parameters)+ radio2 <- radioButtonNewWithLabelFromWidget radio1 label2+ boxPackStart box radio1 PackGrow 2+ boxPackStart box radio2 PackGrow 2+ widgetSetName radio1 $ getParaS "Name" parameters ++ ".1"+ widgetSetName radio2 $ getParaS "Name" parameters ++ ".2"+ containerAdd widget box+ if bool+ then toggleButtonSetActive radio1 True+ else toggleButtonSetActive radio2 True+ reflectState (do+ mapM_ (activateGUIEvent (castToWidget radio1) notifier)+ (Clicked:genericGUIEvents)+ mapM_ (activateGUIEvent (castToWidget radio2) notifier)+ (Clicked:genericGUIEvents)+ retriggerAsChanged notifier [Clicked]) stateR+ writeIORef coreRef (Just (radio1,radio2))+ Just (radio1,radio2) ->+ if bool+ then toggleButtonSetActive radio1 True+ else toggleButtonSetActive radio2 True)+ (liftIO $ do+ core <- readIORef coreRef+ case core of+ Nothing -> return Nothing+ Just (radio1,_) -> do+ r <- toggleButtonGetActive radio1+ return (Just r))+ (("Name", ParaString "") <<< 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 <- liftIO $ newIORef Nothing+ let vals :: [alpha] = allOf+ mkEditor+ (\widget enumValue -> reifyState $ \ stateR -> 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+ reflectState (do+ mapM_+ (\e ->+ (mapM_+ (\b -> activateGUIEvent (castToWidget b) notifier e)+ buttons)) (Clicked:genericGUIEvents)+ retriggerAsChanged notifier [Clicked]) stateR+ 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]))+ (liftIO $ 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)+ (("Name", ParaString "") <<< parameters)+ notifier++++-- | An Editor to display an image+--+imageEditor :: Editor StockId+imageEditor parameters notifier = do+ coreRef <- liftIO $ newIORef Nothing+ mkEditor+ (\widget stockId -> reifyState $ \ _ -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ image <- imageNewFromStock stockId IconSizeLargeToolbar+ widgetSetName image (getParaS "Name" parameters)+ containerAdd widget image+ writeIORef coreRef (Just (image,stockId))+ Just (image,_) -> imageSetFromStock image stockId IconSizeLargeToolbar)+ (liftIO $ 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 <- liftIO $ newIORef Nothing+ mkEditor+ (\widget string -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ entry <- entryNew+ widgetSetName entry (getParaS "Name" parameters)+ reflectState (do+ mapM_ (activateGUIEvent (castToWidget entry) notifier)+ genericGUIEvents+ retriggerAsChanged notifier [KeyPressed]) stateR+ 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))+ (liftIO $ 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 <- liftIO $ newIORef Nothing+ mkEditor+ (\widget string -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ aTextView <- textViewNew+ widgetSetName aTextView (getParaS "Name" parameters)+ aScrolledWindow <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetPolicy aScrolledWindow PolicyAutomatic PolicyAutomatic+ containerAdd aScrolledWindow aTextView+ containerAdd widget aScrolledWindow+ reflectState (do+ mapM_ (activateGUIEvent (castToWidget aTextView) notifier)+ genericGUIEvents+ retriggerAsChanged notifier [KeyPressed]) stateR+ buffer <- textViewGetBuffer aTextView+ textBufferSetText buffer string+ writeIORef coreRef (Just (aScrolledWindow,aTextView))+ Just (_,aTextView) -> do+ buffer <- textViewGetBuffer aTextView+ textBufferSetText buffer string)+ (liftIO $ 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))+ (("HPack",ParaPack PackGrow) <<<("VPack",ParaPack PackGrow) <<< 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 <- liftIO $ newIORef Nothing+ mkEditor+ (\widget v -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ spin <- spinButtonNewWithRange min max step+ widgetSetName spin (getParaS "Name" parameters)+ reflectState (do+ mapM_ (activateGUIEvent (castToWidget spin) notifier)+ (genericGUIEvents)+ activateGUIEvent' (castToWidget spin) notifier+ (\ w h -> do+ res <- afterValueSpinned (castToSpinButton w) (do+ h (Gtk.Event True)+ return ())+ return (unsafeCoerce res))+ MayHaveChanged) stateR+ containerAdd widget spin+ spinButtonSetValue spin (fromIntegral v)+ writeIORef coreRef (Just spin)+ Just spin -> spinButtonSetValue spin (fromIntegral v))+ (liftIO $ 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 -> catchState (liftM Just (liftIO $ readIO s))+ (\ (e :: SomeException) -> do+ message Error ("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 <- liftIO $ newIORef Nothing+ mkEditor+ (\widget _ -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ button <- buttonNewWithLabel (getParaS "Name" parameters)+ widgetSetName button (getParaS "Name" parameters)+ containerAdd widget button+ reflectState (+ mapM_ (activateGUIEvent (castToWidget button) notifier )+ (Clicked:genericGUIEvents)) stateR+ writeIORef coreRef (Just button)+ Just _button -> return ())+ (return (Just ()))+ parameters+ notifier++-- | Since this editor has no value attached, here are dummy getters and setters for it+dummyGetter :: alpha -> ()+dummyGetter = \ _ -> ()+dummySetter :: alpha -> beta -> beta+dummySetter = \ _ b -> b++-- | An Editor for nothing (which may report a click) in the form of a button+-- The editor state reflects the sensitivity state of the button+clickEditor :: Bool -> Editor Bool+clickEditor canDefault parameters notifier = do+ coreRef <- liftIO $ newIORef Nothing+ mkEditor+ (\widget sens -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ button <- case getPara "StockId" parameters of+ ParaString "" -> buttonNewWithLabel (getParaS "Name" parameters)+ ParaString st -> buttonNewFromStock st+ _ -> error "Simnple>>clickEditor: Impossible type"+ widgetSetName button (getParaS "Name" parameters)+ containerAdd widget button+ reflectState(+ activateGUIEvent (castToWidget button) notifier Clicked) stateR+ writeIORef coreRef (Just button)+ widgetSetSensitive widget sens+ when canDefault $ do+ set button [widgetCanDefault := True]+ widgetGrabDefault button+ Just widget -> widgetSetSensitive widget sens)+ (liftIO $ do+ core <- readIORef coreRef+ case core of+ Nothing -> return Nothing+ Just button -> liftM Just (get button widgetSensitive))+ (("Name",ParaString "") <<< 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 <- liftIO $ newIORef Nothing+ mkEditor+ (\widget obj -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ combo <- comboBoxNewText+ mapM_ (\o -> comboBoxAppendText combo (showF o)) list+ widgetSetName combo (getParaS "Name" parameters)+ reflectState (do+ mapM_ (activateGUIEvent (castToWidget combo) notifier )+ genericGUIEvents+ activateGUIEvent' (castToWidget combo) notifier+ (\ w h -> do+ res <- on (castToComboBox w) changed (do+ h (Gtk.Event True)+ return ())+ return (unsafeCoerce res)) MayHaveChanged) stateR+ 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 ())+ (liftIO $ do+ core <- readIORef coreRef+ case core of+ Nothing -> return Nothing+ Just combo -> do+ ind <- comboBoxGetActive combo+ case ind of+ (-1) -> return Nothing+ _ -> 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 <- liftIO $ newIORef Nothing+ mkEditor+ (\widget objs -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ listStore <- listStoreNew ([]:: [alpha])+ listView <- treeViewNewWithModel listStore+ widgetSetName listView (getParaS "Name" parameters)+ reflectState (do+ mapM_ (activateGUIEvent (castToWidget listView) notifier)+ genericGUIEvents+ retriggerAsChanged notifier [KeyPressed,ButtonPressed]) stateR+ 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)+ (liftIO $ do+ core <- readIORef coreRef+ case core of+ Nothing -> return Nothing+ Just (listView,listStore) -> do+ sel <- treeViewGetSelection listView+ treePath <- treeSelectionGetSelectedRows sel+ values <- mapM (\ l ->+ case l of+ [i] -> listStoreGetValue listStore i+ _ -> error+ "Simple>>multiselectionEditor")+ 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 <- liftIO $ newIORef Nothing+ mkEditor+ (\widget objs -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ listStore <- listStoreNew ([]:: [(Bool,beta)])+ listView <- treeViewNewWithModel listStore+ widgetSetName listView (getParaS "Name" parameters)+ reflectState (do+ mapM_ (activateGUIEvent (castToWidget listView) notifier)+ genericGUIEvents+ retriggerAsChanged notifier [KeyPressed,ButtonPressed]) stateR+ 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 ParaSize minSize = getPara "MinSize" 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_ (\ l ->+ case l of+ (i:_) -> do+ val <- listStoreGetValue listStore i+ listStoreSetValue listStore i+ (not (fst val),snd val)+ [] -> error "Simple>>staticListMultiEditor"+ ) 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)+ (liftIO $ 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 <- liftIO $ newIORef Nothing+ mkEditor+ (\widget obj -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ listStore <- listStoreNew ([]:: [alpha])+ listView <- treeViewNewWithModel listStore+ widgetSetName listView (getParaS "Name" parameters)+ reflectState (do+ mapM_ (activateGUIEvent (castToWidget listView) notifier)+ genericGUIEvents+ retriggerAsChanged notifier [KeyPressed,ButtonPressed]) stateR+ sel <- treeViewGetSelection listView+ treeSelectionSetMode sel+ (case getPara "MultiSel" parameters of+ ParaBool True -> SelectionMultiple+ ParaBool False -> SelectionSingle+ _ -> error "Simple>>staticListEditor")+ 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 ParaSize minSize = getPara "MinSize" 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])+ (liftIO $ 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 <- liftIO $ newIORef Nothing+ mkEditor+ (\widget filePath -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ button <- buttonNewWithLabel buttonName+ widgetSetName button $ getParaS "Name" parameters ++ "-button"+ entry <- entryNew+ widgetSetName entry $ getParaS "Name" parameters ++ "-entry"+ -- set entry [ entryEditable := False ]+ reflectState (do+ mapM_ (activateGUIEvent (castToWidget button) notifier)+ (Clicked:genericGUIEvents)+ mapM_ (activateGUIEvent (castToWidget entry) notifier)+ genericGUIEvents+ registerGUIEvent notifier [Clicked] (buttonHandler entry)+ retriggerAsChanged notifier [KeyPressed,ButtonPressed]) stateR++ box <- case getPara "Direction" parameters of+ ParaDir Horizontal -> do+ r <- hBoxNew False 1+ return (castToBox r)+ ParaDir Vertical -> do+ r <- vBoxNew False 1+ return (castToBox r)+ _ -> error "Simple>>fileEditor"+ 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)+ (liftIO $ 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 = reifyState $ \ stateR -> 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{geGtkReturn=True})+ Just fn -> do+-- let relative = case mbFilePath of+-- Nothing -> fn+-- Just rel -> makeRelative rel fn+ entrySetText entry fn+ reflectState (triggerGUIEvent notifier (GUIEvent {+ geSelector = MayHaveChanged,+ geGtkEvent = Gtk.Event True,+ geText = "",+ geMbSelection = Nothing,+ geGtkReturn = True})) stateR+ return (e{geGtkReturn=True})++--+-- | Editor for a font selection+--+fontEditor :: Editor (Maybe String)+fontEditor parameters notifier = do+ coreRef <- liftIO $ newIORef Nothing+ mkEditor+ (\widget mbValue -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ fs <- fontButtonNew+ widgetSetName fs $ getParaS "Name" parameters+ reflectState (do+ mapM_ (activateGUIEvent (castToWidget fs) notifier)+ (Clicked: genericGUIEvents)+ activateGUIEvent' (castToWidget fs) notifier+ (\ w h -> do+ res <- onFontSet (castToFontButton w) (do+ h (Gtk.Event True)+ return ())+ return (unsafeCoerce res)) MayHaveChanged) stateR+ 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 ())+ (liftIO $ 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 <- liftIO $ newIORef Nothing+ mkEditor+ (\widget c -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ cs <- colorButtonNew+ widgetSetName cs $ getParaS "Name" parameters+ reflectState (do+ mapM_ (activateGUIEvent (castToWidget cs) notifier )+ (Clicked: genericGUIEvents)+ activateGUIEvent' (castToWidget cs) notifier+ (\ w h -> do+ res <- onColorSet (castToColorButton w) (do+ h (Gtk.Event True)+ return ())+ return (unsafeCoerce res)) MayHaveChanged) stateR+ containerAdd widget cs+ colorButtonSetColor cs c+ writeIORef coreRef (Just cs)+ Just cs -> colorButtonSetColor cs c)+ (liftIO $ 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 <- liftIO $ newIORef Nothing+ mkEditor+ (\widget val -> reifyState $ \ stateR -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ button <- buttonNewWithLabel (getParaS "Name" parameters)+ widgetSetName button $ getParaS "Name" parameters+ containerAdd widget button+ reflectState (do+ mapM_ (activateGUIEvent (castToWidget button) notifier)+ (Clicked:genericGUIEvents)+ registerGUIEvent notifier [Clicked] (buttonHandler coreRef)+ retriggerAsChanged notifier [KeyPressed,ButtonPressed,Clicked]) stateR+ writeIORef coreRef (Just (button,val))+ Just (button, _oldval) -> writeIORef coreRef (Just (button, val)))+ (liftIO $ do+ core <- readIORef coreRef+ case core of+ Nothing -> return Nothing+ Just (_,val) -> return (Just val))+ (("Name",ParaString "") <<< parameters)+ notifier+ where+ buttonHandler coreRef e = liftIO $ 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 (getParaS "Name" parameters)+ case res of+ Nothing -> return (e{geGtkReturn=True})+ Just nval -> do+ writeIORef coreRef (Just (b, nval))+ return (e{geGtkReturn=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)]+
+ src/Graphics/Panes/Preferences.hs view
@@ -0,0 +1,94 @@+{-# Language ScopedTypeVariables, TypeFamilies, DeriveDataTypeable,+ ExistentialQuantification #-}++-----------------------------------------------------------------------------+--+-- Module : Graphics.Panes.Preferences+-- Copyright : (c) Juergen Nicklisch-Franken+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+--+-- | Module for visually editing generic preferences+--+-----------------------------------------------------------------------------------++module Graphics.Panes.Preferences (++ openPreferencesPane+, PreferencesPane(..)+++) where++import Base+import Graphics.Pane+import Graphics.Forms.Basics+import Graphics.Forms.Build+import Graphics.Forms.FormPane++import Graphics.UI.Gtk+import Data.Typeable (Typeable)+import Base.Preferences (savePrefs, setPrefs)++-- | opens up an editor for preferences+openPreferencesPane :: StateM ()+openPreferencesPane = do+ message Debug "Open preferences pane"+ _mbPane :: Maybe PreferencesPane <- getOrBuildDisplay (Left []) True ()+ return ()++-- ----------------------------------------------+-- * It's a pane+--++data PreferencesPane = PreferencesPane {+ prpTopW :: VBox,+ prpInj :: Injector [GenValue],+ prpExt :: Extractor [GenValue],+ prpEvent :: GEvent+} deriving Typeable+++instance PaneInterface PreferencesPane where+ data PaneState PreferencesPane = PrefPaneState+ deriving(Read,Show)+ type PaneArgs PreferencesPane = ()++ getTopWidget = \ p -> castToWidget (prpTopW p)+ primPaneName = \ _dp -> "PreferencesPane"+ paneType = \ _ -> "**PreferencesPane"+ saveState = \ _s -> return $ Just PrefPaneState+ recoverState = \ pp _ps -> do+ nb <- getNotebook pp+ mbP <- buildPanePrim pp nb (builder ())+ return mbP+ builder = buildPreferencesPane++instance Pane PreferencesPane++++-- ----------------------------------------------+-- * Building the pane in standard form+--+buildPreferencesPane :: () -> PanePath -> Notebook -> Window+ -> StateM (Maybe PreferencesPane, Connections)+buildPreferencesPane _ pp nb window = do++ allPrefs <- getState PrefsDescrState+ let descrs = map (\ (s,GenF fdg v) -> (s,GenFG (toFieldDescriptionG fdg) v))+ allPrefs+ buildGenericFormsPane descrs (formPaneDescr (map fst descrs)) pp nb window+ where+ formPaneDescr categories =+ FormPaneDescr {+ fpGetPane = \ top inj ext gevent -> PreferencesPane top inj ext gevent,+ fpSaveAction = \ v -> do+ mapM (\ (str,GenV val) -> setPrefs str val) (zip categories v)+ currentPrefsPath <- getCurrentPrefsPath+ savePrefs currentPrefsPath,+ fpHasChanged = \ v1 v2 -> v1 == v2,+ fpGuiHandlers = [],+ fpExtraButtons = []}+