diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,165 @@
+ GNU LESSER GENERAL PUBLIC LICENSE
+ Version 3, 29 June 2007
+
+ Copyright (C) 2007 Free Software Foundation, Inc.
+ 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.
diff --git a/Setup.lhs b/Setup.lhs
new file mode 100644
--- /dev/null
+++ b/Setup.lhs
@@ -0,0 +1,6 @@
+#!/usr/bin/runhaskell
+> module Main where
+> import Distribution.Simple
+> main :: IO ()
+> main = defaultMain
+
diff --git a/billeksah-forms.cabal b/billeksah-forms.cabal
new file mode 100644
--- /dev/null
+++ b/billeksah-forms.cabal
@@ -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
diff --git a/src/Base/Preferences.hs b/src/Base/Preferences.hs
new file mode 100644
--- /dev/null
+++ b/src/Base/Preferences.hs
@@ -0,0 +1,141 @@
+{-# Language ExistentialQuantification, TypeFamilies, DeriveDataTypeable #-}
+
+-----------------------------------------------------------------------------
+--
+-- Module : Base.Preferences
+-- Copyright : (c) Juergen Nicklisch-Franken
+-- License : GNU-GPL
+--
+-- Maintainer :
+--
+-- | 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]
diff --git a/src/Graphics/Forms.hs b/src/Graphics/Forms.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/Forms.hs
@@ -0,0 +1,43 @@
+-----------------------------------------------------------------------------
+--
+-- Module : Graphics.Forms
+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
+-- License : GNU-GPL
+--
+-- Maintainer :
+-- 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
+
diff --git a/src/Graphics/Forms/Basics.hs b/src/Graphics/Forms/Basics.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/Forms/Basics.hs
@@ -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 :
+-- 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
diff --git a/src/Graphics/Forms/Build.hs b/src/Graphics/Forms/Build.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/Forms/Build.hs
@@ -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 :
+-- 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)
+
+
+
+
diff --git a/src/Graphics/Forms/Composite.hs b/src/Graphics/Forms/Composite.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/Forms/Composite.hs
@@ -0,0 +1,725 @@
+{-# Language ExistentialQuantification #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Graphics.Forms.Composite
+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
+-- License : GNU-GPL
+--
+-- Maintainer :
+-- 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 "") << 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)) << 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
+
+
+
+
+
+
diff --git a/src/Graphics/Forms/Default.hs b/src/Graphics/Forms/Default.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/Forms/Default.hs
@@ -0,0 +1,46 @@
+
+-----------------------------------------------------------------------------
+--
+-- Module : Default
+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
+-- License : GNU-GPL
+--
+-- Maintainer : Juergen Nicklisch-Franken
+-- Stability : provisional
+-- Portability : portable
+--
+-- | Module for default values of a data type
+--
+------------------------------------------------------------------------------
+
+module 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
+
diff --git a/src/Graphics/Forms/Description.hs b/src/Graphics/Forms/Description.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/Forms/Description.hs
@@ -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 :
+-- 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 ())]
+
diff --git a/src/Graphics/Forms/FormPane.hs b/src/Graphics/Forms/FormPane.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/Forms/FormPane.hs
@@ -0,0 +1,232 @@
+{-# Language RankNTypes #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Graphics.Forms.FormPane
+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
+-- License : GNU-GPL
+--
+-- Maintainer :
+-- 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
+ ("" ++
+ "The following fields have invalid values: "
+ ++ geText e ++ "")
+ 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
diff --git a/src/Graphics/Forms/GUIEvent.hs b/src/Graphics/Forms/GUIEvent.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/Forms/GUIEvent.hs
@@ -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 :
+-- 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 )
diff --git a/src/Graphics/Forms/Parameters.hs b/src/Graphics/Forms/Parameters.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/Forms/Parameters.hs
@@ -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)
+ ]
+
+
diff --git a/src/Graphics/Forms/Sets.hs b/src/Graphics/Forms/Sets.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/Forms/Sets.hs
@@ -0,0 +1,529 @@
+{-# Language ExistentialQuantification #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Graphics.Forms.Sets
+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
+-- License : GNU-GPL
+--
+-- Maintainer :
+-- 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)
+
diff --git a/src/Graphics/Forms/Simple.hs b/src/Graphics/Forms/Simple.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/Forms/Simple.hs
@@ -0,0 +1,888 @@
+{-# Language ScopedTypeVariables, CPP #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Graphics.Forms.Simple
+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
+-- License : GNU-GPL
+--
+-- Maintainer :
+-- 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)]
+
diff --git a/src/Graphics/Panes/Preferences.hs b/src/Graphics/Panes/Preferences.hs
new file mode 100644
--- /dev/null
+++ b/src/Graphics/Panes/Preferences.hs
@@ -0,0 +1,94 @@
+{-# Language ScopedTypeVariables, TypeFamilies, DeriveDataTypeable,
+ ExistentialQuantification #-}
+
+-----------------------------------------------------------------------------
+--
+-- Module : Graphics.Panes.Preferences
+-- Copyright : (c) Juergen Nicklisch-Franken
+-- License : GNU-GPL
+--
+-- Maintainer :
+--
+-- | 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 = []}
+