packages feed

DataTreeView (empty) → 0.1

raw patch · 10 files changed

+897/−0 lines, 10 filesdep +MissingHdep +basedep +bytestringsetup-changed

Dependencies added: MissingH, base, bytestring, containers, deepseq, glib, gtk, monad-control, mtl, syb

Files

+ DataTreeView.cabal view
@@ -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: <http://i.imgur.com/5JlhG.png>+ .+ 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+                      +
+ DataTreeView.hs view
@@ -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
+ DataTreeView/CustomHandlers.hs view
@@ -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
+ DataTreeView/DataToTree.hs view
@@ -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]))++
+ DataTreeView/Row.hs view
@@ -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)++
+ DataTreeView/SimpleView.hs view
@@ -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++
+ DataTreeView/StrictTypes.hs view
@@ -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) +
+ DataTreeView/Widget.hs view
@@ -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 ]) +++
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain