diff --git a/DataTreeView.cabal b/DataTreeView.cabal --- a/DataTreeView.cabal +++ b/DataTreeView.cabal @@ -1,5 +1,5 @@ Name: DataTreeView -Version: 0.1 +Version: 0.1.1 Synopsis: A GTK widget for displaying arbitrary Data.Data.Data instances License: BSD3 License-file: LICENSE @@ -23,10 +23,20 @@ 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 + Build-depends: + bytestring, + mtl >= 2, + containers, + glib >= 0.12, + base >= 4 && < 5, + syb >= 0.3, + MissingH >= 1.1.0.3, + gtk>=0.12, + deepseq, + ListLike >= 3.0.1, + monad-control >= 0.3, + lifted-base, + transformers-base Exposed-modules: DataTreeView DataTreeView.CustomHandlers diff --git a/DataTreeView/CustomHandlers.hs b/DataTreeView/CustomHandlers.hs --- a/DataTreeView/CustomHandlers.hs +++ b/DataTreeView/CustomHandlers.hs @@ -1,16 +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 + -- | The monad in which custom handlers run + MCH,self,genericHandler, + -- * Specialized constructors simpleCH,monoCH,monoPureCH,monoPureCH',poly1CH,poly2CH, - -- ** Data that custom handlers must produce + -- ** ... for containers + AnyData(..),container0CH,container1CH,container2CH, + + -- * Data that custom handlers must produce module DataTreeView.StrictTypes, - CellData,Row(..),newRow,addToAll, - -- *** Cell attributes + CellData, + -- ** Row + Row(..), + -- *** Construction + newRow, + -- *** Modification + addToAll,addFieldName, + -- ** Cell attributes CellAttr,ColorName,txt,bgcolor,bgcolor',fgcolor,fgcolor',scale, -- * Internal dataToTree diff --git a/DataTreeView/DataToTree.hs b/DataTreeView/DataToTree.hs --- a/DataTreeView/DataToTree.hs +++ b/DataTreeView/DataToTree.hs @@ -7,25 +7,29 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS -Wall #-} module DataTreeView.DataToTree where + +import Control.Applicative +import Control.Exception.Lifted +import Control.Monad.Base +import Control.Monad.Reader +import Control.Monad.Trans.Control import Data.Data +import Data.List(intercalate) 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 DataTreeView.Row +import DataTreeView.StrictTypes 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 +import qualified Data.IntMap as IntMap +import qualified Data.Map as Map +import qualified Data.Set as Set @@ -39,11 +43,27 @@ -newtype MCH a = MCH (ReaderT CustomHandlerServices IO a) deriving(Functor,Applicative,Monad, MonadIO, MonadControlIO, Typeable) +newtype MCH a = MCH (ReaderT CustomHandlerServices IO a) + deriving(Functor, Applicative, Monad, MonadIO, MonadBase IO, Typeable) runMCH :: MCH a -> CustomHandlerServices -> IO a runMCH (MCH x) = runReaderT x +instance MonadBaseControl IO MCH where + data StM MCH a = Stm_MCH { unStm_MCH :: StM (ReaderT CustomHandlerServices IO) a } + + liftBaseWith (f :: RunInBase MCH IO -> IO a) = MCH (liftBaseWith f') + where + f' :: RunInBase (ReaderT CustomHandlerServices IO) IO -> IO a + f' rib' = f rib + + where + rib :: forall a'. MCH a' -> IO (StM MCH a') + rib = liftM Stm_MCH . rib' . (\(MCH x) -> x) + + restoreM = MCH . restoreM . unStm_MCH + + -- | 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. @@ -126,11 +146,12 @@ chsSelf :: forall e. Data e => e -> MCH (StrictTree Row) chsSelf x = chsSelf1 x `catch` excHandler + chsSelf1 :: forall e. Data e => e -> MCH (StrictTree Row) chsSelf1 x = do y <- {-# SCC "dataToTree/runCH" #-} runCH ch' x z <- case y of Just y' -> return y' - Nothing -> defaultHandler x + Nothing -> genericHandler x evaluate z excHandler :: SomeException -> MCH (StrictTree Row) @@ -148,9 +169,12 @@ 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) +-- | Generates the subtree using the 'Data' instance of the argument (calls 'self' on the children, not 'genericHandler'). +-- +-- You can invoke this from your 'CustomHandler' and then override some attributes of the result. +genericHandler :: forall e. Data e => e -> MCH (StrictTree Row) +genericHandler x = do + rec <- {-# SCC "genericHandler/rec" #-} sequence (gmapQ self x) ctorRow <- (do let constr = toConstr x @@ -162,14 +186,12 @@ `catch` (return . formatExc) -- Add record field names - let rec' = {-# SCC "defaultHandler/rec'" #-} + let rec' = {-# SCC "genericHandler/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)) + (\n fn -> modifyValue n (addFieldName fn)) rec (fieldNames ++ repeat "") @@ -207,14 +229,25 @@ data AnyData = forall a. Data a => AnyData a +-- | Makes a 'CustomHandler' for container-like types. The given function should return: +-- +-- * The string for the 'rowCV' cell +-- +-- * A list of arbitrary (key,value) pairs to be displayed in the 'rowCustomInfo' cell (this should be things +-- like the size of the collection, not a list of elements) +-- +-- * The list of elements +-- container0CH :: Typeable a => (a -> (String,[(String,String)],[AnyData])) -> CustomHandler container0CH convert = monoCH (\x -> containerCH_common (convert x) (typeOf x)) +-- | Like 'container0CH', but for type constructors container1CH :: Typeable1 f => (forall a. (Data a) => f a -> (String,[(String,String)],[AnyData])) -> CustomHandler container1CH convert = poly1CH (\x -> containerCH_common (convert x) (typeOf x)) +-- | Like 'container1CH', but for binary type constructor 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)) diff --git a/DataTreeView/Row.hs b/DataTreeView/Row.hs --- a/DataTreeView/Row.hs +++ b/DataTreeView/Row.hs @@ -3,7 +3,7 @@ {-# OPTIONS -Wall #-} module DataTreeView.Row(CellData,cellData,unCellData, ColorName,CellAttr,txt,bgcolor,bgcolor',fgcolor,fgcolor',scale,Row(..), - addToAll,convertAttrs,seqListSpine, standardScale) where + addToAll,convertAttrs,seqListSpine, standardScale,addFieldName) where import Control.DeepSeq import Graphics.UI.Gtk import Data.Typeable @@ -93,4 +93,6 @@ convertAttr (Bgcolor' r g b) = cellTextBackgroundColor := Color r g b convertAttr (Scale x) = cellTextScale :~ (*x) +addFieldName :: String -> Row -> Row +addFieldName fn r = r { rowFieldName = rowFieldName r `mappend` strictList [txt fn] } diff --git a/DataTreeView/StrictTypes.hs b/DataTreeView/StrictTypes.hs --- a/DataTreeView/StrictTypes.hs +++ b/DataTreeView/StrictTypes.hs @@ -11,14 +11,14 @@ StrictList, -- ** Construction ToStrictList(..), - -- ** Modification - drop, -- ** Destruction - fromStrictList,foldl', + fromStrictList, -- * Strict trees and forests StrictTree,StrictForest, -- ** Construction ToStrictTree(..),ToStrictForest(..), + -- ** Modification + modifyValue, modifyChildren, -- ** Destruction nodeValue,nodeChildren,fromStrictTree,fromStrictForest) where import Data.Typeable @@ -29,8 +29,11 @@ import Data.Traversable(Traversable) import Data.Data import Data.List(unfoldr) +import Data.ListLike --- Strict lists (in both the head and tail) +-- | Strict lists (in both the head and tail) +-- +-- Note: Most operations for this type are provided via the 'ListLike' instance, but 'ListLike' is not reexported here. data StrictList a = SNil | SCons !a !(StrictList a) deriving(Show,Typeable,Data,Functor,Foldable,Traversable) @@ -43,7 +46,7 @@ -- | From lazy list instance ToStrictList [a] a where - strictList = foldr SCons SNil + strictList = Prelude.foldr SCons SNil -- | Cons instance ToStrictList x a => ToStrictList (a, x) a where @@ -62,24 +65,45 @@ 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 - +instance FoldableLL (StrictList a) a where + -- copied from Data.List + 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 + foldl f z0 xs0 = lgo z0 xs0 + where lgo z SNil = z + lgo z (SCons x xs) = lgo (f z x) xs + foldr f z0 = go + where go SNil = z0 + go (SCons x xs) = f x (go xs) +instance ListLike (StrictList a) a where + singleton = strictList + + head (SCons x _) = x + head _ = error "`head' on empty StrictList" + + tail (SCons _ xs) = xs + tail _ = error "`tail on empty StrictList" + + 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 + + + null (SCons _ _) = False + null SNil = True + + + + -- | Empty list and appending instance Monoid (StrictList a) where mempty = SNil @@ -131,7 +155,14 @@ nodeChildren (SNode _ ts) = fromStrictList ts - +-- | Note: this function is not recursive. +modifyValue :: StrictTree a -> (a -> a) -> StrictTree a +modifyValue (SNode a ts) f = SNode (f a) ts + +-- | Note: this function is not recursive. +modifyChildren + :: StrictTree a -> (StrictForest a -> StrictForest a) -> StrictTree a +modifyChildren (SNode a ts) f = SNode a (f ts) diff --git a/DataTreeView/Widget.hs b/DataTreeView/Widget.hs --- a/DataTreeView/Widget.hs +++ b/DataTreeView/Widget.hs @@ -1,7 +1,7 @@ {-# OPTIONS -Wall #-} module DataTreeView.Widget where ---import Control.DeepSeq +import Control.Applicative import Control.Exception import Control.Monad import Control.Monad.Trans(liftIO) @@ -10,13 +10,12 @@ 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 +import Graphics.UI.Gtk +import Prelude hiding(catch) +import System.Glib dbgChangeCursor :: String -> IO () @@ -184,8 +183,8 @@ attrs <- f x dbgGuardedAttrSetter "Leaving guardedAttrSetter" return attrs) - `catchGError` gErrorHandler - `Control.Exception.catch` handler + `catch` gErrorHandler + `catch` handler where gErrorHandler e = do