diff --git a/DataTreeView.cabal b/DataTreeView.cabal new file mode 100644 --- /dev/null +++ b/DataTreeView.cabal @@ -0,0 +1,39 @@ +Name: DataTreeView +Version: 0.1 +Synopsis: A GTK widget for displaying arbitrary Data.Data.Data instances +License: BSD3 +License-file: LICENSE +Author: Daniel Schüssler +Maintainer: anotheraddress@gmx.de +Category: Development,Debug,GUI +Build-type: Simple +Cabal-version: >=1.6 +Description: + Screenshot: + . + Example use: + . + > import DataTreeView + > main = simpleView [(["hello","world",error "this works too"],25)] + + +Source-Repository head + type: darcs + location: http://patch-tag.com/r/DanielSchuessler/DataTreeView + + +Library + Build-depends: bytestring, monad-control >= 0.2, mtl >= 2, + containers, glib >= 0.12, + base >= 4 && < 5, syb >= 0.3, MissingH >= 1.1.0.3, + gtk>=0.12, deepseq + + Exposed-modules: DataTreeView + DataTreeView.CustomHandlers + DataTreeView.StrictTypes + Other-modules: DataTreeView.DataToTree + DataTreeView.Widget + DataTreeView.SimpleView + DataTreeView.Row + + diff --git a/DataTreeView.hs b/DataTreeView.hs new file mode 100644 --- /dev/null +++ b/DataTreeView.hs @@ -0,0 +1,11 @@ +{-# OPTIONS -Wall #-} +module DataTreeView( + DataTreeView(..), + -- * Construction + dtvNew,dtvNewWithCH, + -- * Launching simple GTK windows + simpleView,simpleViewWithCH, + ) where + +import DataTreeView.Widget +import DataTreeView.SimpleView diff --git a/DataTreeView/CustomHandlers.hs b/DataTreeView/CustomHandlers.hs new file mode 100644 --- /dev/null +++ b/DataTreeView/CustomHandlers.hs @@ -0,0 +1,24 @@ +{-# OPTIONS -Wall #-} +module DataTreeView.CustomHandlers( + module DataTreeView, + -- * Custom handlers + CustomHandler(..), showType, showTypeOf, + -- ** The monad in which custom handlers run + MCH,self, + -- ** Specialized constructors + simpleCH,monoCH,monoPureCH,monoPureCH',poly1CH,poly2CH, + -- ** Data that custom handlers must produce + module DataTreeView.StrictTypes, + CellData,Row(..),newRow,addToAll, + -- *** Cell attributes + CellAttr,ColorName,txt,bgcolor,bgcolor',fgcolor,fgcolor',scale, + -- * Internal + dataToTree + ) where + +import DataTreeView +import DataTreeView.DataToTree +import DataTreeView.Row +import Data.Monoid +import Data.Tree +import DataTreeView.StrictTypes diff --git a/DataTreeView/DataToTree.hs b/DataTreeView/DataToTree.hs new file mode 100644 --- /dev/null +++ b/DataTreeView/DataToTree.hs @@ -0,0 +1,299 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# OPTIONS -Wall #-} +module DataTreeView.DataToTree where +import Data.Data +import Data.Monoid +import Data.String.Utils(replace) +import Control.Monad.IO.Control +import Control.Exception.Control +import Control.Applicative +import Control.Monad.Reader +import Prelude hiding(catch) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import Data.List(intercalate) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Internal as BSI +import qualified Data.ByteString.Lazy.Char8 as BL +import DataTreeView.Row +import DataTreeView.StrictTypes + + + + + +-- | Functionality a @CustomHandler@ may use. +data CustomHandlerServices = CHS { + chsSelf :: forall d. Data d => d -> MCH (StrictTree Row) +} + deriving(Typeable) + + + +newtype MCH a = MCH (ReaderT CustomHandlerServices IO a) deriving(Functor,Applicative,Monad, MonadIO, MonadControlIO, Typeable) + +runMCH :: MCH a -> CustomHandlerServices -> IO a +runMCH (MCH x) = runReaderT x + +-- | Invokes the /final/ Data-to-Tree conversion function, which includes the generic handler, the 'CustomHandler' being defined, and any 'CustomHandler's 'mappend'ed to the one being defined. +-- +-- Thus, invoking @'self' x@ from your implementation of @'runCH' x@ will usually amount to an infinite loop, but invoking @'self' y@ on some child @y@ of @x@ is fine. +self :: Data d => d -> MCH (StrictTree Row) +self x = do + f <- MCH (asks chsSelf) + f x + + + + + + +-- | Custom handlers are used for overriding the generic formatting behaviour at some values (for example, printing a @String@ directly into the /Constructor or value/ column rather than as a list of chars). +-- +-- If a custom handler matches (returns a 'Just'), no recursion into its children is performed by default. You can recurse manually using 'self'. +newtype CustomHandler = CH { runCH :: forall d. Data d => d -> MCH (Maybe (StrictTree Row)) } + + +-- | Creates a custom handler that only applies at a fixed monomorphic type @a@. +monoCH :: Typeable a => (a -> MCH (Maybe (StrictTree Row))) -> CustomHandler +monoCH f = CH (case cast f of + Nothing -> \_ -> return Nothing + Just f' -> f') + +-- | Creates a pure custom handler that only applies at a fixed monomorphic type @a@. +monoPureCH :: Typeable a => (a -> (Maybe (StrictTree Row))) -> CustomHandler +monoPureCH f = CH (case cast f of + Nothing -> \_ -> return Nothing + Just f' -> return . f') + +-- | Creates a pure custom handler that only and always applies at a fixed monomorphic type @a@. +monoPureCH' :: Typeable a => (a -> StrictTree Row) -> CustomHandler +monoPureCH' f = CH (case cast f of + Nothing -> \_ -> return Nothing + Just f' -> return . Just . f') + +-- | Creates a custom handler that applies at @f a@ for a fixed type constructor @f@ and for any @a@. +poly1CH :: Typeable1 f => (forall a. Data a => f a -> MCH (Maybe (StrictTree Row))) -> CustomHandler +poly1CH f = CH (case dataCast1 (Q f) of + Nothing -> \_ -> return Nothing + Just (Q f') -> f') + +-- | Creates a custom handler that applies at @f a b@ for a fixed binary type constructor @f@ and for any @a@ and @b@. +poly2CH :: Typeable2 f => (forall a b. (Data a, Data b) => f a b -> MCH (Maybe (StrictTree Row))) -> CustomHandler +poly2CH f = CH (case dataCast2 (Q f) of + Nothing -> \_ -> return Nothing + Just (Q f') -> f') + +-- from syb +newtype Q q x = Q { unQ :: x -> q } + + +-- | The 'mempty' 'CustomHandler' handles nothing. @'mappend' ch1 ch2@ tries @ch1@ first, falling back to @ch2@ if @ch1@ doesn't handle the argument. +instance Monoid CustomHandler where + mempty = CH (\_ -> return Nothing) + mappend ch1 ch2 = CH (\x -> do + y1 <- runCH ch1 x + case y1 of + Just _ -> return y1 + Nothing -> runCH ch2 x) + +-- | Construct a 'Row' with empty 'rowFieldName'. +-- +-- You usually can't know the field name for a node @x@ during a recursive call with @x@ at its root - the field name will be added /afterwards/ by the generic handler for the parent node of @x@ if that parent node is a constructor with named fields. +newRow :: [CellAttr] -- ^ 'rowCV' + -> [CellAttr] -- ^ 'rowCustomInfo' + -> [CellAttr] -- ^ 'rowTypeName' + -> Row +newRow (cellData -> rowCV) (cellData -> rowCustomInfo) (cellData -> rowTypeName) = + Row {rowCV,rowTypeName,rowCustomInfo,rowFieldName = mempty} + +dataToTree :: forall d. Data d => CustomHandler -> d -> IO (StrictTree Row) +dataToTree ch = \x -> runMCH (chsSelf x) customHandlerServices + where + customHandlerServices = CHS {chsSelf} + + ch' = ch `mappend` builtinCH + + chsSelf :: forall e. Data e => e -> MCH (StrictTree Row) + chsSelf x = chsSelf1 x `catch` excHandler + + chsSelf1 x = do + y <- {-# SCC "dataToTree/runCH" #-} runCH ch' x + z <- case y of + Just y' -> return y' + Nothing -> defaultHandler x + evaluate z + +excHandler :: SomeException -> MCH (StrictTree Row) +excHandler e = return (strictTree (formatExc e)) + + + +formatExc :: SomeException -> Row +formatExc (SomeException e) = + newRow + (colored [txt $ show e]) + (colored [txt $ showAttrList [("exception type",show (typeOf e))]]) + mempty + where + colored = ([ bgcolor $ "black", fgcolor $ "white" ] ++) + + +defaultHandler :: forall e. Data e => e -> MCH (StrictTree Row) +defaultHandler x = do + rec <- {-# SCC "defaultHandler/rec" #-} sequence (gmapQ self x) + + ctorRow <- (do + let constr = toConstr x + ctorText <- (evaluate . showConstr) constr + return $ case constrRep constr of + AlgConstr _ -> newRow [ txt $ ctorText ] [] [txt $ showTypeOf x] + _ -> formatLit ctorText "" (typeOf x) + ) + `catch` (return . formatExc) + + -- Add record field names + let rec' = {-# SCC "defaultHandler/rec'" #-} + case safeConstrFields x of + Nothing -> rec + Just fieldNames -> + zipWith + (\n b -> + let nodeValue' = (nodeValue n) { rowFieldName = cellData [ txt $ b ] } + in strictTree (nodeValue', nodeChildren n)) + rec + (fieldNames ++ repeat "") + + + return $ strictTree (ctorRow, rec') + +safeConstrFields :: Data a => a -> Maybe [String] +safeConstrFields x = + case dataTypeRep (dataTypeOf x) of + AlgRep _ -> case constrFields (toConstr x) of + [] -> Nothing + xs -> Just xs + _ -> Nothing + +-- safeConstrFields :: Constr -> Maybe [String] +-- safeConstrFields c = unsafePerformIO ( +-- (Just <$> evaluate (constrFields c)) `Control.Exception.catch` (\(SomeException e) -> return Nothing) +-- ) + + +builtinCH :: CustomHandler +builtinCH = mconcat [strCH, lstCH, mapCH, setCH, intMapCH, bsCH, blCH, funCH] + +lstCH :: CustomHandler +lstCH = container1CH (\x -> ("List",[("length",(show . length) x)],fmap AnyData x)) + +mapCH :: CustomHandler +mapCH = container2CH (\x -> ("Map",[("size",(show . Map.size) x)], (fmap AnyData . Map.toList) x)) + +setCH :: CustomHandler +setCH = container1CH (\x -> ("Set",[("size",(show . Set.size) x)],(fmap AnyData . Set.toList) x)) + +intMapCH :: CustomHandler +intMapCH = container1CH (\x -> ("IntMap",[("size",(show . IntMap.size) x)],(fmap AnyData . IntMap.toList) x)) + +data AnyData = forall a. Data a => AnyData a + +container0CH :: Typeable a => + (a -> (String,[(String,String)],[AnyData])) -> CustomHandler +container0CH convert = monoCH (\x -> containerCH_common (convert x) (typeOf x)) + +container1CH :: Typeable1 f => + (forall a. (Data a) => f a -> (String,[(String,String)],[AnyData])) -> CustomHandler +container1CH convert = poly1CH (\x -> containerCH_common (convert x) (typeOf x)) + +container2CH :: Typeable2 f => + (forall a b. (Data a, Data b) => f a b -> (String,[(String,String)],[AnyData])) -> CustomHandler +container2CH convert = poly2CH (\x -> containerCH_common (convert x) (typeOf x)) + + +containerCH_common :: (String,[(String,String)],[AnyData]) -> TypeRep -> MCH (Maybe (StrictTree Row)) +containerCH_common (name,attrs,asList) typeRep = do + cs <- mapM (\(AnyData y) -> self y) asList + let row = + newRow [ txt $ concat ["{",name,"}"] ] + [ txt $ showAttrList attrs] + [ txt $ showType typeRep ] + + `addToAll` [ fgcolor' 0 0 0xA000 ] + + (return . Just) (strictTree (row,cs)) + + + + +showAttrList :: [(String, String)] -> String +showAttrList = intercalate ", " . (fmap (\(k,v) -> k ++ "=" ++ v)) + + +strCH :: CustomHandler +strCH = monoPureCH' (\x -> {-# SCC "strCH/body" #-} + (strictTree (formatLit (show (x::String)) "" (typeOf x)) + )) + +-- | Strict ByteString +bsCH :: CustomHandler +bsCH = monoPureCH' (\x@(BSI.PS addr offset length_) -> + strictTree (formatLit + ((show . BS.unpack) x) + (showAttrList [("addr",show addr) ,("offset",show offset) ,("length",show length_)]) + (typeOf x)) + ) + +-- | Lazy ByteString +blCH :: CustomHandler +blCH = container0CH (\x -> + let + chunks = BL.toChunks x + in + ("Lazy ByteString", [("nchunks",(show . length) chunks)], fmap AnyData chunks)) + + + +funCH :: CustomHandler +funCH = poly2CH (\x -> + let + _types = x undefined + color = fgcolor "darkorange" + row = newRow [txt "{function}", color ] + [] [txt $ showTypeOf x, color] + in + (return . Just . strictTree) row) + + +formatLit :: String -> String -> TypeRep -> Row +formatLit x info t = newRow [ txt $ x ] [ txt $ info ] [ txt $ showType t ] + + `addToAll` [ fgcolor' 0 0x8000 0 ] + + + + +-- | Show a type with some prettification like replacing @[Char]@ with @String@. +showType :: TypeRep -> String +showType = replace "[Char]" "String" . show + +showTypeOf :: Typeable a => a -> String +showTypeOf = showType . typeOf + +-- | A 'CustomHandler' that only works at a fixed type (and always works there), and generates a node with no children and with the default text in the /type/ column. +-- The function should return the 'rowCV' in the first component and the 'rowCustomInfo' in the second. +simpleCH :: Typeable a => (a -> MCH ([CellAttr],[CellAttr])) -> CustomHandler +simpleCH f = monoCH (\x -> do + (y1,y2) <- f x + (return . Just) $ strictTree (newRow y1 y2 [txt $ showTypeOf x])) + + diff --git a/DataTreeView/Row.hs b/DataTreeView/Row.hs new file mode 100644 --- /dev/null +++ b/DataTreeView/Row.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE DeriveDataTypeable, BangPatterns, GeneralizedNewtypeDeriving, DeriveDataTypeable, + ViewPatterns, DeriveFunctor, StandaloneDeriving #-} +{-# OPTIONS -Wall #-} +module DataTreeView.Row(CellData,cellData,unCellData, + ColorName,CellAttr,txt,bgcolor,bgcolor',fgcolor,fgcolor',scale,Row(..), + addToAll,convertAttrs,seqListSpine, standardScale) where +import Control.DeepSeq +import Graphics.UI.Gtk +import Data.Typeable +import Data.Monoid +import DataTreeView.StrictTypes +import Data.Data +import Data.Word + +seqListSpine :: [t1] -> t -> t +seqListSpine [] x = x +seqListSpine (_:xs) x = xs `seqListSpine` x + + + + +type CellData = StrictList CellAttr + + +cellData :: [CellAttr] -> CellData +cellData = strictList + +unCellData :: CellData -> [CellAttr] +unCellData = fromStrictList + +type ColorName = String + + + + +-- | Cell attributes +data CellAttr = + Txt !String + -- yes, the !String isn't strict enough; thus the smart constructors + | Bgcolor !ColorName + | Bgcolor' !Word16 !Word16 !Word16 -- ^ Expanded because 'Color' doesn't have a 'Data' instances and I don't want the code to break once it does + | Fgcolor !String + | Fgcolor' !Word16 !Word16 !Word16 + | Scale !Double + deriving(Show,Typeable,Data,Eq,Ord) + +-- | The cell's text. If this attribute occurs multiple times for a single cell, the occurences are concatenated. +txt :: String -> CellAttr +txt x = rnf x `seq` Txt x +-- | Background color, by name +bgcolor :: ColorName -> CellAttr +bgcolor x = rnf x `seq` Bgcolor x +-- | Background color, red\/green\/blue +bgcolor' :: Word16 -> Word16 -> Word16 -> CellAttr +bgcolor' = Bgcolor' +-- | Foreground color, by name +fgcolor :: ColorName -> CellAttr +fgcolor x = rnf x `seq` Fgcolor x +-- | Foreground color, red\/green\/blue +fgcolor' :: Word16 -> Word16 -> Word16 -> CellAttr +fgcolor' = Fgcolor' +-- | Font scaling factor +scale :: Double -> CellAttr +scale = Scale -- . (*standardScale) + +standardScale :: Double +standardScale = 0.75 + +-- | Data for a row of the tree widget. +data Row = Row { + rowCV :: !CellData -- ^ Constructor name, literal value, or a placeholder like @\"{List}\"@ for custom things + , rowFieldName :: !CellData -- ^ Record field name. You can mostly ignore this, see the remark in 'newRow'. + , rowCustomInfo :: !CellData -- ^ Arbitrary information (left empty by the generic handler) + , rowTypeName :: !CellData +} deriving(Show,Typeable,Data) + +-- | Adds the given attribute to each cell of the given row. +addToAll :: Row -> [CellAttr] -> Row +addToAll r (cellData -> x) + = r { rowCV = rowCV r `mappend` x + , rowFieldName = rowFieldName r `mappend` x + , rowCustomInfo = rowCustomInfo r `mappend` x + , rowTypeName = rowTypeName r `mappend` x + } + +convertAttrs :: CellRendererTextClass c => CellData -> [AttrOp c] +convertAttrs = fmap convertAttr . fromStrictList + where + convertAttr (Txt x) = cellText :~ (++x) + convertAttr (Fgcolor x) = cellTextForeground := x + convertAttr (Fgcolor' r g b) = cellTextForegroundColor := Color r g b + convertAttr (Bgcolor x) = cellTextBackground := x + convertAttr (Bgcolor' r g b) = cellTextBackgroundColor := Color r g b + convertAttr (Scale x) = cellTextScale :~ (*x) + + diff --git a/DataTreeView/SimpleView.hs b/DataTreeView/SimpleView.hs new file mode 100644 --- /dev/null +++ b/DataTreeView/SimpleView.hs @@ -0,0 +1,29 @@ +{-# OPTIONS -Wall #-} +module DataTreeView.SimpleView where +import Graphics.UI.Gtk +import Data.Data +import Data.Monoid +import Control.Monad.Trans + +import DataTreeView.Widget +import DataTreeView.DataToTree + +simpleView :: Data d => [d] -> IO () +simpleView = simpleViewWithCH mempty + +simpleViewWithCH :: Data d => CustomHandler -> [d] -> IO () +simpleViewWithCH ch xs = do + _ <- initGUI + window <- windowNew + _ <- window `on` deleteEvent $ liftIO (mainQuit >> return False) + + dtv <- dtvNewWithCH ch xs + + set window [ windowTypeHint := WindowTypeHintNormal + , containerChild := dtv ] + + -- i.e., on window deleteEvent (liftIO mainQuit >> return False) + widgetShowAll window + mainGUI + + diff --git a/DataTreeView/StrictTypes.hs b/DataTreeView/StrictTypes.hs new file mode 100644 --- /dev/null +++ b/DataTreeView/StrictTypes.hs @@ -0,0 +1,145 @@ +{-# LANGUAGE DeriveDataTypeable,DeriveFunctor,BangPatterns,DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable,NoMonomorphismRestriction, FlexibleContexts,FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS -Wall #-} +-- | Remark: the heavy use of strictness here is for correctly catching exceptions, not for performance reasons +module DataTreeView.StrictTypes( + module Data.Tree, + module Data.Monoid, + -- * Strict lists + StrictList, + -- ** Construction + ToStrictList(..), + -- ** Modification + drop, + -- ** Destruction + fromStrictList,foldl', + -- * Strict trees and forests + StrictTree,StrictForest, + -- ** Construction + ToStrictTree(..),ToStrictForest(..), + -- ** Destruction + nodeValue,nodeChildren,fromStrictTree,fromStrictForest) where +import Data.Typeable +import Data.Monoid +import Prelude hiding(drop) +import Data.Tree +import Data.Foldable(Foldable) +import Data.Traversable(Traversable) +import Data.Data +import Data.List(unfoldr) + +-- Strict lists (in both the head and tail) +data StrictList a = SNil | SCons !a !(StrictList a) + deriving(Show,Typeable,Data,Functor,Foldable,Traversable) + +class ToStrictList x a where + strictList :: x -> StrictList a + +-- | Singleton +instance ToStrictList a a where + strictList x = SCons x SNil + +-- | From lazy list +instance ToStrictList [a] a where + strictList = foldr SCons SNil + +-- | Cons +instance ToStrictList x a => ToStrictList (a, x) a where + strictList (a,x) = SCons a (strictList x) + +-- | Identity +instance ToStrictList (StrictList a) a where + strictList = id + + + +fromStrictList :: StrictList a -> [a] +fromStrictList = unfoldr f + where + f SNil = Nothing + f (SCons x xs) = Just (x,xs) + + +-- copied from Data.List +foldl' :: (r -> a -> r) -> r -> StrictList a -> r +foldl' f z0 xs0 = lgo z0 xs0 + where lgo z SNil = z + lgo z (SCons x xs) = let z' = f z x in z' `seq` lgo z' xs + + + +drop :: (Integral a) => a -> StrictList t -> StrictList t +drop n xs | n < 0 = error "Strict.drop: n<0" + | otherwise = go n xs + where + go 0 xs' = xs' + go n' (SCons _ xs'') = go (pred n') xs'' + go _ SNil = SNil + + + +-- | Empty list and appending +instance Monoid (StrictList a) where + mempty = SNil + mappend SNil !b = b + mappend (SCons a1 a2) !b = SCons a1 (mappend a2 b) + +data StrictTree a = SNode !a !(StrictForest a) deriving(Show,Typeable,Data,Functor,Foldable,Traversable) + +type StrictForest a = StrictList (StrictTree a) + +class ToStrictTree x a where + strictTree :: x -> StrictTree a + +-- | Leaf +instance ToStrictTree a a where + strictTree = flip SNode SNil + +-- | From lazy tree +instance ToStrictTree (Tree a) a where + strictTree (Node a ts) = SNode a (strictForest ts :: StrictForest a) + +-- | From node value and subforest +instance ToStrictForest y a => ToStrictTree (a, y) a where + strictTree (a,y) = SNode a (strictForest y) + +-- | Identity +instance ToStrictTree (StrictTree a) a where + strictTree = id + +class ToStrictForest y a where + strictForest :: y -> StrictForest a + +instance (ToStrictTree x a) => ToStrictForest [x] a where + strictForest = strictList . fmap (strictTree :: x -> StrictTree a) + +instance (ToStrictTree x a) => ToStrictForest (StrictList x) a where + strictForest = strictList . fmap (strictTree :: x -> StrictTree a) + +-- | Identity +instance ToStrictForest (StrictForest a) a where + strictForest = id + + + +nodeValue :: StrictTree a -> a +nodeValue (SNode a _) = a + +nodeChildren :: StrictTree t -> [StrictTree t] +nodeChildren (SNode _ ts) = fromStrictList ts + + + + + + +fromStrictForest :: StrictForest a -> Forest a +fromStrictForest = fmap fromStrictTree . fromStrictList + +fromStrictTree :: StrictTree a -> Tree a +fromStrictTree = unfoldTree f + where + f (SNode a ts) = (a, fromStrictList ts) + diff --git a/DataTreeView/Widget.hs b/DataTreeView/Widget.hs new file mode 100644 --- /dev/null +++ b/DataTreeView/Widget.hs @@ -0,0 +1,222 @@ +{-# OPTIONS -Wall #-} +module DataTreeView.Widget where + +--import Control.DeepSeq +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 Graphics.UI.Gtk +import System.Glib + +import DataTreeView.DataToTree +import DataTreeView.Row +import DataTreeView.StrictTypes +import Control.Applicative + + +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"] + + -- Set (the same) renderer for all columns + renderer <- cellRendererTextNew + mapM_ (\c -> cellLayoutPackEnd c renderer False) cols + + -- Set Row -> attributes functions + zipWithM_ (\c -> cellLayoutSetAttributesIO c renderer treeModel) + cols + [simpleAttrSetter rowCV + ,simpleAttrSetter rowFieldName + ,simpleAttrSetter rowCustomInfo + ,simpleAttrSetter rowTypeName + ] + + -- Append all the columns to the TreeView + 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 +-- changeCursorByIter :: (TreeIter -> IO TreeIter) -> IO Bool +-- changeCursorByIter f = do +-- (path,_) <- treeViewGetCursor treeView +-- mbIter <- treeModelGetIter treeModel path +-- case mbIter of +-- Nothing -> putStrLn "Warning: treeViewGetCursor returned an invalid TreePath" +-- Just iter -> +-- f iter >>= maybe (return ()) +-- ((\path' -> treeViewSetCursor treeView path' Nothing) +-- <=< treeModelGetPath treeModel ) +-- +-- return True + + 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" + --node <- treeStoreLookup treeModel path' + 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 + +-- | Zero-based. +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 ) + -- putStrLn ("Attrs = "++show y) + 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) + `catchGError` gErrorHandler + `Control.Exception.catch` handler + + where + gErrorHandler e = do + putStrLn ("GError caught: "++showGError e) + return [cellText := "GERROR: " ++ showGError e] + + handler (SomeException e) = do + --putStrLn ("Exception caught: "++show e) + 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 + , {- cellTextScaleSet, -} cellTextStyleSet, cellTextVariantSet ]) + + + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Daniel Schüssler + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Daniel Schüssler nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain