DataTreeView 0.1 → 0.1.1

raw patch · 6 files changed

+141/−58 lines, 6 filesdep +ListLikedep +lifted-basedep +transformers-basedep ~monad-controlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: ListLike, lifted-base, transformers-base

Dependency ranges changed: monad-control

API changes (from Hackage documentation)

Files

• DataTreeView.cabal +15/−5
• DataTreeView/CustomHandlers.hs +15/−7
• DataTreeView/DataToTree.hs +52/−19
• DataTreeView/Row.hs +3/−1
• DataTreeView/StrictTypes.hs +50/−19
• DataTreeView/Widget.hs +6/−7

@@ -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

@@ -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

@@ -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))

@@ -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] } 

@@ -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)   

@@ -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