{-# LANGUAGE CPP #-}
module Game.Goatee.Ui.Gtk.NodePropertiesPanel (
NodePropertiesPanel,
create,
destroy,
myWidget,
) where
import Control.Arrow ((+++))
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>), (<*), (*>))
#endif
import Control.Monad (forM_, unless, when)
import qualified Data.Foldable as Foldable
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.List (sortBy)
import Data.Ord (comparing)
import Game.Goatee.Lib.Board
import Game.Goatee.Lib.Monad hiding (on)
import Game.Goatee.Lib.Parser
import Game.Goatee.Lib.Property
import Game.Goatee.Lib.Renderer
import Game.Goatee.Lib.Renderer.Tree
import Game.Goatee.Ui.Gtk.Common
import Graphics.UI.Gtk (
AttrOp ((:=)),
ListStore,
Packing (PackGrow, PackNatural),
PolicyType (PolicyAutomatic),
ResponseId (ResponseCancel, ResponseOk),
TreeViewColumnSizing (TreeViewColumnAutosize),
Widget,
WrapMode (WrapWord),
boxPackStart,
bufferChanged,
buttonActivated, buttonNewWithLabel,
cellLayoutSetAttributes, cellRendererTextNew, cellText,
containerAdd,
dialogAddButton, dialogGetUpper, dialogNew, dialogRun, dialogSetDefaultResponse,
get,
hBoxNew,
labelNew, labelText,
listStoreAppend, listStoreClear, listStoreNew, listStoreToList,
on,
scrolledWindowNew, scrolledWindowSetPolicy,
set,
stockAdd, stockCancel, stockEdit,
textBufferText,
textViewGetBuffer, textViewNew, textViewSetWrapMode,
toWidget,
treeSelectionGetSelectedRows,
treeViewAppendColumn, treeViewColumnNew, treeViewColumnSizing, treeViewColumnPackStart,
treeViewColumnTitle, treeViewGetSelection, treeViewNewWithModel,
vBoxNew,
widgetDestroy, widgetSetSensitive, widgetShowAll,
windowSetDefaultSize, windowSetTitle,
)
import System.Glib (glibToString)
import Text.ParserCombinators.Parsec (eof, parse, spaces)
data NodePropertiesPanel ui = NodePropertiesPanel
{ myUi :: ui
, myState :: ViewState
, myWidget :: Widget
, myModel :: ListStore Property
, myModelProperties :: IORef [Property]
}
instance UiCtrl go ui => UiView go ui (NodePropertiesPanel ui) where
viewName = const "NodePropertiesPanel"
viewCtrl = myUi
viewState = myState
viewUpdate = update
create :: UiCtrl go ui => ui -> IO (NodePropertiesPanel ui)
create ui = do
vBox <- vBoxNew False 0
buttonBox <- hBoxNew True 0
boxPackStart vBox buttonBox PackNatural 0
addButton <- buttonNewWithLabel "Add"
editButton <- buttonNewWithLabel "Edit"
deleteButton <- buttonNewWithLabel "Del"
mapM_ (containerAdd buttonBox) [addButton, editButton, deleteButton]
model <- listStoreNew []
modelProperties <- newIORef []
column <- treeViewColumnNew
set column [treeViewColumnSizing := TreeViewColumnAutosize,
treeViewColumnTitle := "Property"]
renderer <- cellRendererTextNew
treeViewColumnPackStart column renderer True
cellLayoutSetAttributes column renderer model $ \property ->
let name = propertyName property
value = case runRender $ propertyValueRendererPretty property property of
Left _ -> "(render error)"
Right result -> result
in [cellText := name ++ " " ++ value]
view <- treeViewNewWithModel model
treeViewAppendColumn view column
selection <- treeViewGetSelection view
viewScroll <- scrolledWindowNew Nothing Nothing
scrolledWindowSetPolicy viewScroll PolicyAutomatic PolicyAutomatic
containerAdd viewScroll view
boxPackStart vBox viewScroll PackGrow 0
state <- viewStateNew
let me = NodePropertiesPanel { myUi = ui
, myState = state
, myWidget = toWidget vBox
, myModel = model
, myModelProperties = modelProperties
}
on addButton buttonActivated $ do
maybeProperty <- runPropertyEditDialog "Add property" (glibToString stockAdd) Nothing
Foldable.forM_ maybeProperty $ doUiGo ui . putProperty
on editButton buttonActivated $ do
rows <- map head <$> treeSelectionGetSelectedRows selection
case rows of
[] -> return ()
row:_ -> do
oldProperty <- (!! row) <$> readIORef modelProperties
maybeNewProperty <- runPropertyEditDialog "Edit property" (glibToString stockEdit) $
Just oldProperty
case maybeNewProperty of
Nothing -> return ()
Just newProperty -> doUiGo ui $ do
deleteProperty oldProperty
putProperty newProperty
on deleteButton buttonActivated $ do
rows <- map head <$> treeSelectionGetSelectedRows selection
properties <- readIORef modelProperties
unless (null rows) $
doUiGo ui $ forM_ rows $ deleteProperty . (properties !!)
register me
[ AnyEvent navigationEvent
, AnyEvent propertiesModifiedEvent
]
viewUpdate me
return me
destroy :: UiCtrl go ui => NodePropertiesPanel ui -> IO ()
destroy = viewDestroy
update :: UiCtrl go ui => NodePropertiesPanel ui -> IO ()
update me = do
cursor <- readCursor $ myUi me
let model = myModel me
modelProperties = myModelProperties me
newProperties = sortBy (comparing propertyName) $ cursorProperties cursor
oldProperties <- listStoreToList model
when (newProperties /= oldProperties) $ do
listStoreClear model
forM_ newProperties $ listStoreAppend model
writeIORef modelProperties newProperties
runPropertyEditDialog :: String
-> String
-> Maybe Property
-> IO (Maybe Property)
runPropertyEditDialog dialogTitle acceptButtonLabel initialProperty = do
dialog <- dialogNew
windowSetTitle dialog dialogTitle
windowSetDefaultSize dialog 500 225
upper <- dialogGetUpper dialog
helpLabel <- labelNew $ Just "Enter a property in SGF notation."
boxPackStart upper helpLabel PackNatural 0
textView <- textViewNew
textViewSetWrapMode textView WrapWord
textScroll <- scrolledWindowNew Nothing Nothing
scrolledWindowSetPolicy textScroll PolicyAutomatic PolicyAutomatic
containerAdd textScroll textView
boxPackStart upper textScroll PackGrow 0
textBuffer <- textViewGetBuffer textView
errorLabel <- labelNew (Nothing :: Maybe String)
boxPackStart upper errorLabel PackNatural 0
dialogAddButton dialog stockCancel ResponseCancel
acceptButton <- dialogAddButton dialog acceptButtonLabel ResponseOk
dialogSetDefaultResponse dialog ResponseOk
currentState <- newIORef (Left "" :: Either String Property)
let setState errorOrProperty =
case errorOrProperty of
Left errorMsg -> do
set errorLabel [labelText := errorMsg]
writeIORef currentState $ Left errorMsg
widgetSetSensitive acceptButton False
Right property -> do
set errorLabel [labelText := ""]
writeIORef currentState $ Right property
widgetSetSensitive acceptButton True
parseInput = do
text <- get textBuffer textBufferText
setState $
if null text
then Left ""
else (show +++ id) $
parse (spaces *> propertyParser <* spaces <* eof) "<property>" text
set textBuffer [textBufferText :=
maybe "" (either (const "") id . runRender . renderProperty) initialProperty]
on textBuffer bufferChanged parseInput
parseInput
widgetShowAll dialog
response <- dialogRun dialog
widgetDestroy dialog
case response of
ResponseOk -> do
finalState <- readIORef currentState
case finalState of
Left _ -> return Nothing
Right property -> return $ Just property
_ -> return Nothing