X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=Data%2FGenerics%2FSchemes.hs;h=5234b01a4804197c1e382e776fdb143bfd58476b;hb=9185a42d2848131d1272e79cf1e04430fb96b6d0;hp=5ee9b3a9347fc7938c08f68126c5b7a367b15cd5;hpb=b6ef4d7236a944f4ffed7aaa0fa8fcfe18cb77b9;p=ghc-base.git

diff --git a/Data/Generics/Schemes.hs b/Data/Generics/Schemes.hs
index 5ee9b3a..5234b01 100644
--- a/Data/Generics/Schemes.hs
+++ b/Data/Generics/Schemes.hs
@@ -25,6 +25,13 @@ module Data.Generics.Schemes (
 	listify,
         something,
 	synthesize,
+	gsize,
+	glength,
+	gdepth,
+	gcount,
+	gnodecount,
+	gtypecount,
+	gfindtype
 
  ) where
 
@@ -113,7 +120,49 @@ something = everything orElse
 -- | Bottom-up synthesis of a data structure;
 --   1st argument z is the initial element for the synthesis;
 --   2nd argument o is for reduction of results from subterms;
---   3rd argument f updates the sythesised data according to the given term
+--   3rd argument f updates the synthesised data according to the given term
 --
 synthesize :: s  -> (s -> s -> s) -> GenericQ (s -> s) -> GenericQ s
 synthesize z o f x = f x (foldr o z (gmapQ (synthesize z o f) x))
+
+
+-- | Compute size of an arbitrary data structure
+gsize :: Data a => a -> Int
+gsize t = 1 + sum (gmapQ gsize t)
+
+
+-- | Count the number of immediate subterms of the given term
+glength :: GenericQ Int
+glength = length . gmapQ (const ())
+
+
+-- | Determine depth of the given term
+gdepth :: GenericQ Int
+gdepth = (+) 1 . foldr max 0 . gmapQ gdepth
+
+
+-- | Determine the number of all suitable nodes in a given term
+gcount :: GenericQ Bool -> GenericQ Int
+gcount p =  everything (+) (\x -> if p x then 1 else 0)
+
+
+-- | Determine the number of all nodes in a given term
+gnodecount :: GenericQ Int
+gnodecount = gcount (const True)
+
+
+-- | Determine the number of nodes of a given type in a given term
+gtypecount :: Typeable a => a -> GenericQ Int
+gtypecount (_::a) = gcount (False `mkQ` (\(_::a) -> True))
+
+
+-- | Find (unambiguously) an immediate subterm of a given type
+gfindtype :: (Data x, Typeable y) => x -> Maybe y
+gfindtype = singleton
+          . foldl unJust []
+          . gmapQ (Nothing `mkQ` Just)
+ where
+  unJust l (Just x) = x:l
+  unJust l Nothing  = l
+  singleton [s] = Just s
+  singleton _   = Nothing