syb 0.2.2 → 0.3
raw patch · 6 files changed
+153/−15 lines, 6 files
Files
- src/Data/Generics/Aliases.hs +60/−5
- src/Data/Generics/Schemes.hs +9/−4
- syb.cabal +2/−2
- tests/Ext2.hs +65/−0
- tests/FoldTree.hs +15/−4
- tests/Main.hs +2/−0
src/Data/Generics/Aliases.hs view
@@ -46,12 +46,20 @@ choiceQ, -- * Type extension for unary type constructors+ ext1, ext1T, ext1M, ext1Q, ext1R,- ext1B+ ext1B, + -- * Type extension for binary type constructors+ ext2T,+ ext2M,+ ext2Q,+ ext2R,+ ext2B+ ) where #ifdef __HADDOCK__@@ -304,13 +312,9 @@ --------------------------------------------------------------------------------- -- Type extension for unary type constructors--- ------------------------------------------------------------------------------ -- -- | Flexible type extension ext1 :: (Data a, Typeable1 t) => c a@@ -357,6 +361,57 @@ -> (forall b. Data b => (t b)) -> a ext1B def ext = unB ((B def) `ext1` (B ext))++------------------------------------------------------------------------------+-- Type extension for binary type constructors+------------------------------------------------------------------------------++-- | Flexible type extension+ext2 :: (Data a, Typeable2 t)+ => c a+ -> (forall d1 d2. (Data d1, Data d2) => c (t d1 d2))+ -> c a+ext2 def ext = maybe def id (dataCast2 ext)+++-- | Type extension of transformations for unary type constructors+ext2T :: (Data d, Typeable2 t)+ => (forall e. Data e => e -> e)+ -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> t d1 d2)+ -> d -> d+ext2T def ext = unT ((T def) `ext2` (T ext))+++-- | Type extension of monadic transformations for type constructors+ext2M :: (Monad m, Data d, Typeable2 t)+ => (forall e. Data e => e -> m e)+ -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> m (t d1 d2))+ -> d -> m d+ext2M def ext = unM ((M def) `ext2` (M ext))+++-- | Type extension of queries for type constructors+ext2Q :: (Data d, Typeable2 t)+ => (d -> q)+ -> (forall d1 d2. (Data d1, Data d2) => t d1 d2 -> q)+ -> d -> q+ext2Q def ext = unQ ((Q def) `ext2` (Q ext))+++-- | Type extension of readers for type constructors+ext2R :: (Monad m, Data d, Typeable2 t)+ => m d+ -> (forall d1 d2. (Data d1, Data d2) => m (t d1 d2))+ -> m d+ext2R def ext = unR ((R def) `ext2` (R ext))+++-- | Type extension of builders for type constructors+ext2B :: (Data a, Typeable2 t)+ => a+ -> (forall d1 d2. (Data d1, Data d2) => (t d1 d2))+ -> a+ext2B def ext = unB ((B def) `ext2` (B ext)) ------------------------------------------------------------------------------ --
src/Data/Generics/Schemes.hs view
@@ -26,6 +26,7 @@ everywhereM, somewhere, everything,+ everythingBut, listify, something, synthesize,@@ -102,14 +103,18 @@ -- use gmapQ to recurse into immediate subterms; -- use ordinary foldl to reduce list of intermediate results -- -everything k f x- = foldl k (f x) (gmapQ (everything k f) x)+everything k f x = foldl k (f x) (gmapQ (everything k f) x) +-- | Variation of "everything" with an added stop condition+everythingBut :: (r -> r -> r) -> GenericQ (r, Bool) -> GenericQ r+everythingBut k f x = let (v, stop) = f x+ in if stop+ then v+ else foldl k v (gmapQ (everythingBut k f) x) -- | Get a list of all entities that meet a predicate listify :: Typeable r => (r -> Bool) -> GenericQ [r]-listify p- = everything (++) ([] `mkQ` (\x -> if p x then [x] else []))+listify p = everything (++) ([] `mkQ` (\x -> if p x then [x] else [])) -- | Look up a subterm by means of a maybe-typed filter
syb.cabal view
@@ -1,5 +1,5 @@ name: syb-version: 0.2.2+version: 0.3 license: BSD3 license-file: LICENSE author: Ralf Lammel, Simon Peyton Jones@@ -19,7 +19,7 @@ stability: provisional build-type: Custom cabal-version: >= 1.6-tested-with: GHC == 6.10.4, GHC == 6.12.3, GHC == 7.0.0.20100925+tested-with: GHC == 6.10.4, GHC == 6.12.3, GHC == 7.0.1 extra-source-files: tests/*.hs
+ tests/Ext2.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Ext2 (tests) where++-- Tests for ext2 and friends++import Test.HUnit+import Data.Generics+++-- A type of lists+data List a = Nil | Cons a (List a) deriving (Data, Typeable, Show, Eq)++-- Example lists+l1, l2 :: List Int+l1 = Cons 1 (Cons 2 Nil)+l2 = Cons 0 l1++-- A type of pairs+data Pair a b = Pair1 a b | Pair2 a b deriving (Data, Typeable, Show, Eq)++-- Example pairs+p1, p2 :: Pair Int Char+p1 = Pair1 2 'p'+p2 = Pair2 3 'q'++-- Structures containing the above+s1 :: [Pair Int Char]+s1 = [p1, p2]++s2 :: (Pair Int Char, List Int)+s2 = (p2, l2)+++-- Auxiliary functions+unifyPair :: Pair a b -> Pair a b -> Bool+unifyPair (Pair1 _ _) (Pair1 _ _) = True+unifyPair (Pair2 _ _) (Pair2 _ _) = True+unifyPair _ _ = False++flipPair :: Pair a b -> Pair a b+flipPair (Pair1 a b) = Pair2 a b+flipPair (Pair2 a b) = Pair1 a b++-- Tests+t1 = everywhere (id `ext2T` flipPair) (s1,s2)+t2 = let f :: (Data a) => a -> Maybe a+ f = (const Nothing) `ext2M` (Just . flipPair)+ in (f p1, f l1)+t3 = everything (+) ( const 0+ `ext1Q` (const 1 :: List a -> Int)+ `ext2Q` (const 10 :: Pair a b -> Int))+ $ s2+t4 = unifyPair (t4' :: Pair Int Char) t4' where+ t4' :: Data a => a+ t4' = undefined `ext1B` Nil `ext2B` (Pair1 undefined undefined)+++-- Main function for testing+tests = (t1, t2, t3, t4) ~=? output++output = ((map flipPair s1, (flipPair p2, l2))+ ,(Just (flipPair p1),Nothing)+ ,14+ ,True)
tests/FoldTree.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-} {- @@ -45,19 +46,29 @@ mytree = Fork (WithWeight (Leaf 42) 1) (WithWeight (Fork (Leaf 88) (Leaf 37)) 2) +-- A less typical tree, used for testing everythingBut+mytree' :: Tree Int Int+mytree' = Fork (Leaf 42)+ (WithWeight (Fork (Leaf 88) (Leaf 37)) 2) + -- Print everything like an Int in mytree -- In fact, we show two attempts: -- 1. print really just everything like an Int -- 2. print everything wrapped with Leaf -- So (1.) confuses leafs and weights whereas (2.) does not.--- +-- Additionally we test everythingBut, stopping when we see a WithWeight node tests = show ( listify (\(_::Int) -> True) mytree , everything (++) ([] `mkQ` fromLeaf) mytree+ , everythingBut (++) + (([],False) `mkQ` (\x -> (fromLeaf x, stop x))) mytree' ) ~=? output where fromLeaf :: Tree Int Int -> [Int] fromLeaf (Leaf x) = [x]- fromLeaf _ = []+ fromLeaf _ = []+ stop :: (Data a, Data b) => Tree a b -> Bool+ stop (WithWeight _ _) = True+ stop _ = False -output = "([42,1,88,37,2],[42,88,37])"+output = "([42,1,88,37,2],[42,88,37],[42])"
tests/Main.hs view
@@ -8,6 +8,7 @@ import qualified Builders import qualified Datatype import qualified Ext1+import qualified Ext2 import qualified FoldTree import qualified FreeNames import qualified GEq@@ -70,6 +71,7 @@ , GenUpTo.tests , FreeNames.tests , Ext1.tests+ , Ext2.tests , Bits.tests , Builders.tests ]