billeksah-forms-1.0.0: src/Graphics/Forms/Basics.hs
{-# Language MultiParamTypeClasses, ScopedTypeVariables, FlexibleContexts, RankNTypes,
ExistentialQuantification, DeriveDataTypeable, TypeFamilies #-}
-----------------------------------------------------------------------------
--
-- Module : Graphics.Forms.Basics
-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
-- License : GNU-GPL
--
-- Maintainer : <maintainer at leksah.org>
-- Stability : provisional
-- Portability : portable
--
-- | Module for the basiscs of composing GUIs from editors
--
-----------------------------------------------------------------------------------
module Graphics.Forms.Basics (
-- * Types
Getter
, Setter
, Injector
, Extractor
, Applicator
, Editor
, GUIEvent(..)
, GUIEventSelector(..)
, GEvent
, GenSelection(..)
, genericGUIEvents
, allGUIEvents
, pluginNameForms
, FieldDescription(..)
, GenFieldDescription(..)
, GenValue(..)
, castFD
, toGenFieldDescr
, toFieldEditor
, SectionName
, PrefsDescrState(..)
, FormsEvent(..)
, FormsEventSel(..)
, triggerFormsEvent
, getFormsEvent
, setCurrentPrefsPath
, getCurrentPrefsPath
, registerCurrentPrefsPath
) where
import Base
import Graphics.Forms.Parameters
import Graphics.UI.Gtk
import qualified Graphics.UI.Gtk.Gdk.Events as Gtk
import Control.Monad
import Data.Typeable (Typeable(..), Typeable1, cast, Typeable)
import qualified Text.PrettyPrint as PP (Doc)
import qualified Text.ParserCombinators.Parsec as P (CharParser)
import Debug.Trace (trace)
import Data.Maybe (fromJust)
pluginNameForms :: [Char]
pluginNameForms = "billeksah-forms"
-- ---------------------------------------------------------------------
-- * Basic Types
--
--
-- | A type for getting a field of a record
--
type Getter alpha beta = alpha -> beta
--
-- | A type for setting the field of a record
--
type Setter alpha beta = beta -> alpha -> alpha
--
-- | A type for injecting a value into an editor
--
type Injector beta = beta -> StateM ()
--
-- | A type for extracting a value from an editor
--
type Extractor beta = StateM (Maybe beta)
--
-- | A type for the application of a value to be reflected in the GUI
--
type Applicator beta = beta -> StateM ()
--
-- | A type to describe an editor.
-- alpha is the type of the individual field of the record
type Editor alpha = Parameters -> GEvent -> StateM(Widget, Injector alpha , Extractor alpha)
type GEvent = EventChannel GUIEvent
--
-- | A type for an event in the GUI
--
data GUIEvent = GUIEvent {
geSelector :: GUIEventSelector
, geGtkEvent :: Gtk.Event
, geText :: String
, geMbSelection :: Maybe GenSelection
, geGtkReturn :: Bool -- ^ True means that the event has been completely handled,
-- gtk shoudn't do any further action about it (Often not
-- a good idea
} deriving Typeable
data GUIEventSelector = FocusOut -- ^ generic, the widget looses the focus
| FocusIn -- ^ generic, the widget gets the focus
| ButtonPressed -- ^ generic, a mouse key has been pressed and released, while the widget has the focus
| KeyPressed -- ^ generic, a keyboard key has been pressed and released, while the widget has the focus
| Clicked -- ^ button specific, the button has been pressed
| MayHaveChanged -- ^ generic, no gui event, the contents of the widget may have changed
| ValidationError -- ^ validation of a contents has failed
| Selection
| Dummy
deriving (Eq,Ord,Show,Bounded, Typeable, Enum)
instance Selector GUIEventSelector where
type ValueType GUIEventSelector = EventChannel GUIEvent
data GenSelection = forall alpha . Typeable alpha => GenSelection alpha
allGUIEvents, genericGUIEvents :: [GUIEventSelector]
genericGUIEvents = [FocusOut,FocusIn,ButtonPressed,KeyPressed]
allGUIEvents = allOf
-- * A description for fields, that can be edited with a GUI
--
data FieldDescription alpha = Field {
fdParameters :: Parameters
, fdFieldPrinter :: alpha -> PP.Doc
, fdFieldParser :: alpha -> P.CharParser () alpha
, fdFieldEditor :: alpha -> StateM (Widget, Injector alpha , alpha -> Extractor alpha , GEvent)
, fdApplicator :: alpha -> alpha -> StateM ()}
| VertBox Parameters [FieldDescription alpha] -- ^ Vertical Box
| HoriBox Parameters [FieldDescription alpha] -- ^ Horizontal Box
| TabbedBox [(String,FieldDescription alpha)] -- ^ Notebook
deriving (Typeable)
-- | A type neutral FieldDescription with a type neutral value attached
data GenFieldDescription = forall alpha . (Typeable alpha, Eq alpha) => GenF (FieldDescription alpha) alpha
-- | A type neutral value of a field description
data GenValue = forall alpha . (Typeable alpha, Eq alpha) => GenV alpha
deriving Typeable
instance Eq GenValue where
(GenV a) == (GenV b) = if typeOf a == typeOf b then
fromJust (cast a) == b
else False
toGenFieldDescr :: (Typeable alpha, Eq alpha) => FieldDescription alpha ->
FieldDescription GenValue
toGenFieldDescr (VertBox paras fdl) = VertBox paras (map toGenFieldDescr fdl)
toGenFieldDescr (HoriBox paras fdl) = HoriBox paras (map toGenFieldDescr fdl)
toGenFieldDescr (TabbedBox list) = TabbedBox
(map (\(s,fd) -> (s,toGenFieldDescr fd)) list)
toGenFieldDescr (Field paras fdFieldPrinter fdFieldParser fdFieldEditor fdApplicator)
= trace (show paras) $ Field
paras
(\ (GenV a) ->
let a' = myCast "Basics>>toGenFieldDescr:1 " a
in fdFieldPrinter a')
(\ (GenV a) ->
let a' = myCast "Basics>>toGenFieldDescr:2 " a
in liftM GenV (fdFieldParser a'))
(\ (GenV a) ->
let a' = myCast "Basics>>toGenFieldDescr:3 " a
in liftM toFieldEditor (fdFieldEditor a'))
(\ (GenV a) (GenV b) ->
let (a', b') = (myCast "Basics>>toGenFieldDescr:4 " a,
myCast "Basics>>toGenFieldDescr:5 " b)
in fdApplicator a' b')
-- | A cast from a type neutral FieldDescription with a type neutral value
-- to a typed field description with a typed value
castFD :: (Typeable alpha, Typeable1 FieldDescription, Typeable GenValue) =>
FieldDescription GenValue -> FieldDescription alpha
castFD fdGen = myCast "Basics>>castFD" fdGen
toFieldEditor :: (Typeable alpha, Eq alpha) => (Widget,
Injector alpha,
alpha -> Extractor alpha,
GEvent)
-> (Widget,
Injector GenValue,
GenValue -> Extractor GenValue,
GEvent)
toFieldEditor (widget, inj, ext, gevent) =
(widget,
(\ (GenV a) -> let a' = myCast "Basics>>toFieldEditor:1" a
in inj a'),
(\ (GenV a) -> let a' = myCast "Basics>>toFieldEditor:2" a
in liftM genMaybe (ext a')),
gevent)
where
genMaybe :: (Typeable alpha, Eq alpha) => Maybe alpha -> Maybe GenValue
genMaybe Nothing = Nothing
genMaybe (Just a) = Just (GenV a)
-- -----------------------------------------------
-- * Events the gui frame triggers
--
-- | The events of the forms plugin
data FormsEvent =
RegisterPrefs [(String,GenFieldDescription)]
-- ^ Callback to register perferences
| PrefsChanged
-- ^ The preferences have changed
| NeedRestart
-- ^ The application needs to be restarted to apply the changed preferences
deriving Typeable
data FormsEventSel = FormsEventSel
deriving (Eq, Ord, Show, Typeable)
instance Selector FormsEventSel where
type ValueType FormsEventSel = EventChannel FormsEvent
triggerFormsEvent :: FormsEvent -> StateM (FormsEvent)
triggerFormsEvent = triggerEvent FormsEventSel
getFormsEvent :: StateM (EventChannel FormsEvent)
getFormsEvent = getEvent FormsEventSel
-------------------------------------
-- * Defining the state
--
type SectionName = String
-- | The description and current value of preferences
data PrefsDescrState = PrefsDescrState
deriving (Eq, Ord, Show, Typeable)
-- | The description and current value of preferences
instance Selector PrefsDescrState where
type ValueType PrefsDescrState = [(SectionName,GenFieldDescription)]
-- | The file path for preferences
data PrefsPathSel = PrefsPathSel
deriving (Eq,Ord,Show,Typeable)
-- | The file path for preferences
instance Selector PrefsPathSel where
type ValueType PrefsPathSel = FilePath
setCurrentPrefsPath :: FilePath -> StateM ()
setCurrentPrefsPath = setState PrefsPathSel
getCurrentPrefsPath :: StateM FilePath
getCurrentPrefsPath = getState PrefsPathSel
registerCurrentPrefsPath :: FilePath -> StateM (Maybe String)
registerCurrentPrefsPath = registerState PrefsPathSel