--group_Test
module Graphics.UI.Editor.MakeEditor (
buildEditor
, FieldDescription(..)
, mkField
, extractAndValidate
, extract
, mkEditor
, parameters
, flattenFieldDescription
, getRealWidget
, MkFieldDescription
) where
import Graphics.UI.Gtk
import Control.Monad
import Data.List (unzip4, intersperse)
import Data.Text (Text)
import Data.Monoid ((<>), mconcat)
import Control.Event
import Graphics.UI.Editor.Parameters
import Graphics.UI.Editor.Basics
import Data.Maybe (fromMaybe, isNothing)
import Data.IORef (newIORef)
import qualified Graphics.UI.Gtk.Gdk.Events as GTK (Event(..))
type MkFieldDescription alpha beta =
Parameters ->
Getter alpha beta ->
Setter alpha beta ->
Editor beta ->
FieldDescription alpha
data FieldDescription alpha = FD Parameters (alpha -> IO (Widget, Injector alpha ,
alpha -> Extractor alpha , Notifier))
| VFD Parameters [FieldDescription alpha]
| HFD Parameters [FieldDescription alpha]
| NFD [(Text,FieldDescription alpha)]
parameters :: FieldDescription alpha -> Parameters
parameters (FD p _) = p
parameters (VFD p _) = p
parameters (HFD p _) = p
parameters (NFD _) = emptyParams
newNotebook :: IO Notebook
newNotebook = do
nb <- notebookNew
notebookSetTabPos nb PosTop
notebookSetShowTabs nb True
notebookSetScrollable nb True
notebookSetPopup nb True
return nb
buildEditor :: FieldDescription alpha -> alpha -> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier)
buildEditor (FD paras editorf) v = editorf v
buildEditor (HFD paras descrs) v = buildBoxEditor descrs Horizontal v
buildEditor (VFD paras descrs) v = buildBoxEditor descrs Vertical v
buildEditor (NFD pairList) v = do
nb <- newNotebook
notebookSetShowTabs nb False
resList <- mapM ((`buildEditor` v) . snd) pairList
let (widgets, setInjs, getExts, notifiers) = unzip4 resList
notifier <- emptyNotifier
mapM_ (\ (labelString, widget) -> do
sw <- scrolledWindowNew Nothing Nothing
scrolledWindowAddWithViewport sw widget
scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic
notebookAppendPage nb sw labelString)
(zip (map fst pairList) widgets)
listStore <- listStoreNew (map fst pairList)
listView <- treeViewNewWithModel listStore
widgetSetSizeRequest listView 100 (1)
sel <- treeViewGetSelection listView
treeSelectionSetMode sel SelectionSingle
renderer <- cellRendererTextNew
col <- treeViewColumnNew
treeViewAppendColumn listView col
cellLayoutPackStart col renderer True
cellLayoutSetAttributes col renderer listStore $ \row ->
[ cellText := row ]
treeViewSetHeadersVisible listView False
treeSelectionSelectPath sel [0]
notebookSetCurrentPage nb 0
on sel treeSelectionSelectionChanged (do
selections <- treeSelectionGetSelectedRows sel
case selections of
[[i]] -> notebookSetCurrentPage nb i
_ -> return ())
hb <- hBoxNew False 0
sw <- scrolledWindowNew Nothing Nothing
containerAdd sw listView
scrolledWindowSetPolicy sw PolicyNever PolicyAutomatic
boxPackStart hb sw PackNatural 0
boxPackEnd hb nb PackGrow 7
let newInj v = mapM_ (\ setInj -> setInj v) setInjs
let newExt v = extract v getExts
mapM_ (propagateEvent notifier notifiers) allGUIEvents
return (castToWidget hb, newInj, newExt, notifier)
buildBoxEditor :: [FieldDescription alpha] -> Direction -> alpha
-> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier)
buildBoxEditor descrs dir v = do
resList <- mapM (`buildEditor` v) descrs
notifier <- emptyNotifier
let (widgets, setInjs, getExts, notifiers) = unzip4 resList
hb <- case dir of
Horizontal -> do
b <- hBoxNew False 0
return (castToBox b)
Vertical -> do
b <- vBoxNew False 0
return (castToBox b)
let newInj v = mapM_ (\ setInj -> setInj v) setInjs
let fieldNames = map (fromMaybe "Unnamed" . getParameterPrim paraName . parameters) descrs
let packParas = map (getParameter paraPack . parameters) descrs
mapM_ (propagateEvent notifier notifiers) allGUIEvents
let newExt v = extractAndValidate v getExts fieldNames notifier
mapM_ (\ (w,p) -> boxPackStart hb w p 0) $ zip widgets packParas
return (castToWidget hb, newInj, newExt, notifier)
flattenFieldDescription :: FieldDescription alpha -> [FieldDescription alpha]
flattenFieldDescription (VFD paras descrs) = concatMap flattenFieldDescription descrs
flattenFieldDescription (HFD paras descrs) = concatMap flattenFieldDescription descrs
flattenFieldDescription (NFD descrp) = concatMap (flattenFieldDescription.snd) descrp
flattenFieldDescription fd = [fd]
mkField :: Eq beta => MkFieldDescription alpha beta
mkField parameters getter setter editor =
FD parameters
(\ dat -> do
noti <- emptyNotifier
(widget,inj,ext) <- editor parameters noti
let pext a = do
b <- ext
case b of
Just b -> return (Just (setter b a))
Nothing -> return Nothing
inj (getter dat)
return (widget,
inj . getter,
pext,
noti))
mkEditor :: (Container -> Injector alpha) -> Extractor alpha -> Editor alpha
mkEditor injectorC extractor parameters notifier = do
let (xalign, yalign, xscale, yscale) = getParameter paraOuterAlignment parameters
outerAlig <- alignmentNew xalign yalign xscale yscale
let (paddingTop, paddingBottom, paddingLeft, paddingRight) = getParameter paraOuterPadding parameters
alignmentSetPadding outerAlig paddingTop paddingBottom paddingLeft paddingRight
frame <- frameNew
frameSetShadowType frame (getParameter paraShadow parameters)
case getParameter paraName parameters of
"" -> return ()
str -> when (getParameter paraShowLabel parameters) $
frameSetLabel frame str
containerAdd outerAlig frame
let (xalign, yalign, xscale, yscale) = getParameter paraInnerAlignment parameters
innerAlig <- alignmentNew xalign yalign xscale yscale
let (paddingTop, paddingBottom, paddingLeft, paddingRight) = getParameter paraInnerPadding parameters
alignmentSetPadding innerAlig paddingTop paddingBottom paddingLeft paddingRight
containerAdd frame innerAlig
let (x,y) = getParameter paraMinSize parameters
widgetSetSizeRequest outerAlig x y
let name = getParameter paraName parameters
widgetSetName outerAlig name
let build = injectorC (castToContainer innerAlig)
return (castToWidget outerAlig, build, extractor)
extractAndValidate :: alpha -> [alpha -> Extractor alpha] -> [Text] -> Notifier -> IO (Maybe alpha)
extractAndValidate val getExts fieldNames notifier = do
(newVal,errors) <- foldM (\ (val,errs) (ext,fn) -> do
extVal <- ext val
case extVal of
Just nval -> return (nval,errs)
Nothing -> return (val, (" " <> fn) : errs))
(val,[]) (zip getExts fieldNames)
if null errors
then return (Just newVal)
else do
triggerEvent notifier GUIEvent {
selector = ValidationError,
eventText = mconcat (intersperse ", " errors),
gtkReturn = True}
return Nothing
extract :: alpha -> [alpha -> Extractor alpha] -> IO (Maybe alpha)
extract val =
foldM (\ mbVal ext ->
case mbVal of
Nothing -> return Nothing
Just val -> ext val)
(Just val)
getRealWidget :: Widget -> IO (Maybe Widget)
getRealWidget w = do
mbF <- binGetChild (castToBin w)
case mbF of
Nothing -> return Nothing
Just f -> do
mbIA <- binGetChild (castToBin f)
case mbIA of
Nothing -> return Nothing
Just iA -> binGetChild (castToBin iA)