module DataTreeView.Widget where
import Control.Applicative
import Control.Exception
import Control.Monad
import Control.Monad.Trans(liftIO)
import Data.Data
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Tree
import DataTreeView.DataToTree
import DataTreeView.Row
import DataTreeView.StrictTypes
import Graphics.UI.Gtk
import Prelude hiding(catch)
import System.Glib
dbgChangeCursor :: String -> IO ()
dbgChangeCursor = const (return ())
dbgGuardedAttrSetter :: String -> IO ()
dbgGuardedAttrSetter = const (return ())
dbg :: String -> IO ()
dbg = putStrLn
data DataTreeView = DataTreeView {
dtvTreeView :: TreeView
}
instance TreeViewClass DataTreeView
instance ContainerClass DataTreeView
instance WidgetClass DataTreeView
instance ObjectClass DataTreeView
instance GObjectClass DataTreeView where
toGObject = toGObject . dtvTreeView
unsafeCastGObject = DataTreeView . unsafeCastGObject
dtvNew :: Data d => [d] -> IO DataTreeView
dtvNew = dtvNewWithCH mempty
dtvNewWithCH :: Data d => CustomHandler -> [d] -> IO DataTreeView
dtvNewWithCH ch xs = do
forest <- let f = fmap fromStrictTree . fromStrictList . strictList
in f <$> mapM (dataToTree ch) xs
treeModel <- treeStoreNew forest
treeView <- treeViewNewWithModel treeModel
cols <- replicateM 4 treeViewColumnNew
mapM_ (\c -> set c [ treeViewColumnResizable := True
, treeViewColumnReorderable := True ]) cols
zipWithM_ treeViewColumnSetTitle cols ["Constructor or value", "Field name", "Custom info", "Type"]
renderer <- cellRendererTextNew
mapM_ (\c -> cellLayoutPackEnd c renderer False) cols
zipWithM_ (\c -> cellLayoutSetAttributesIO c renderer treeModel)
cols
[simpleAttrSetter rowCV
,simpleAttrSetter rowFieldName
,simpleAttrSetter rowCustomInfo
,simpleAttrSetter rowTypeName
]
mapM_ (treeViewAppendColumn treeView) cols
_ <- on treeView keyPressEvent (theOnKeyPress forest treeView)
treeViewExpandAll treeView
return DataTreeView { dtvTreeView = treeView }
theOnKeyPress
:: TreeViewClass self =>
[Tree t]
-> self
-> EventM EKey Bool
theOnKeyPress forest treeView = do
kn <- eventKeyName
case kn of
"j" -> changeCursor (modifyLast succ)
"k" -> changeCursor (modifyLast pred)
"l" -> changeCursor (++[0])
"h" -> changeCursor dropLast
_ -> return False
where
changeCursor f = liftIO $ do
dbgChangeCursor "Entering changeCursor"
(path,_) <- treeViewGetCursor treeView
dbgChangeCursor ("\tpath = "++ show path)
let path' = f path
dbgChangeCursor ("\tpath' = "++ show path')
dbgChangeCursor "\tgetting node"
let node_ = forestLookupPath forest path'
dbgChangeCursor ("\tisJust node = "++show (isJust node_))
when (isJust node_) $ do
treeViewExpandToPath treeView path'
treeViewSetCursor treeView path' Nothing
(path'',_) <- treeViewGetCursor treeView
dbgChangeCursor ("\tpath'' = "++ show path'')
dbgChangeCursor "Leaving changeCursor"
return True
forestLookupPath :: [Tree t] -> [Int] -> Maybe (Tree t)
forestLookupPath _ [] = Nothing
forestLookupPath ts (i:is) = flip treeLookupPath is =<< maybeIth ts i
treeLookupPath :: Tree t -> [Int] -> Maybe (Tree t)
treeLookupPath t [] = Just t
treeLookupPath (Node _ f) is = forestLookupPath f is
maybeIth :: [a] -> Int -> Maybe a
maybeIth lst i | i < 0 = Nothing
| otherwise =
case Prelude.drop i lst of
[] -> Nothing
(t:_) -> Just t
modifyLast :: (a -> a) -> [a] -> [a]
modifyLast f = unfoldr g
where
g [] = Nothing
g [x] = Just (f x,[])
g (x:xs) = Just (x,xs)
dropLast :: [a] -> [a]
dropLast = unfoldr g
where
g [] = Nothing
g [_] = Nothing
g (x:xs) = Just (x,xs)
showGError :: GError -> String
showGError (GError a b c) = show (a,b,c)
simpleAttrSetter
:: CellRendererTextClass self =>
(Row -> CellData) -> Row -> IO [AttrOp self]
simpleAttrSetter f = guardedAttrSetter (\x -> do
y <- evaluate ( f x )
return (convertAttrs y))
guardedAttrSetter :: CellRendererTextClass cr => (Row -> IO [AttrOp cr]) -> Row -> IO [AttrOp cr]
guardedAttrSetter f x =
(do
dbgGuardedAttrSetter "Entering guardedAttrSetter"
attrs <- f x
dbgGuardedAttrSetter "Leaving guardedAttrSetter"
return attrs)
`catch` gErrorHandler
`catch` handler
where
gErrorHandler e = do
putStrLn ("GError caught: "++showGError e)
return [cellText := "GERROR: " ++ showGError e]
handler (SomeException e) = do
return [cellText := "EXCEPTION: " ++ show e]
cellLayoutSetAttributesIO ::
( TypedTreeModelClass model,
CellLayoutClass lay,
CellRendererTextClass cell,
TreeModelClass (model row)) =>
lay -> cell -> model row -> (row -> IO [AttrOp cell]) -> IO ()
cellLayoutSetAttributesIO self_ cell model attributes =
cellLayoutSetAttributeFunc self_ cell model $ \iter -> do
set cell attrResets
row <- treeModelGetRow model iter
attrs <- attributes row
set cell attrs
where
attrResets = (cellText := "") : ( cellTextScale := standardScale ) :
(fmap (\a -> a := False)
[ cellBackgroundSet, cellTextBackgroundSet, cellTextForegroundSet, cellTextSizeSet
, cellTextStyleSet, cellTextVariantSet ])