From ad8aab723be24b87b9dda30224e3aa51c5421a40 Mon Sep 17 00:00:00 2001
From: Neil Brown <neil@twistedsquare.com>
Date: Wed, 12 Sep 2007 00:11:22 +0000
Subject: [PATCH] Added a function for searching for particular constructors in
 a tree, and an associated test

---
 common/CommonTest.hs | 26 ++++++++++++++++++++++++++
 common/TreeUtil.hs   | 32 +++++++++++++++++++++++++++++++-
 2 files changed, 57 insertions(+), 1 deletion(-)

diff --git a/common/CommonTest.hs b/common/CommonTest.hs
index 2483b66..5aad643 100644
--- a/common/CommonTest.hs
+++ b/common/CommonTest.hs
@@ -21,6 +21,9 @@ module CommonTest (tests) where
 import Test.HUnit hiding (State)
 import qualified AST as A
 import Types
+import TreeUtil
+import Metadata
+import Data.Generics
 
 -- | Tests the isSafeConversion function:
 testIsSafeConversion :: Test
@@ -82,10 +85,33 @@ testIsSafeConversion = TestList $ map runTestRow resultsWithIndexes
        ,[t, t,t,t,f, t,t,t,t,t] --to Int64
       ]
 
+testCheckTreeForConstr :: Test
+testCheckTreeForConstr = TestList
+ [
+   doTest (0,A.Int,[],[])
+  ,doTest (1,A.Int,[tc0 A.Int],[ADI A.Int])
+  ,doTest (100, A.True emptyMeta, [tc1 A.True],[ADI $ A.True emptyMeta])
+  
+  ,doTest (200, A.Seq emptyMeta $ A.Several emptyMeta [A.OnlyP emptyMeta $ A.Skip emptyMeta], [tc1 A.Skip], [ADI $ A.Skip emptyMeta])
+  ,doTest (201, A.Seq emptyMeta $ A.Several emptyMeta [A.OnlyP emptyMeta $ A.Skip emptyMeta], [tc2 A.Several], [ADI $ A.Several emptyMeta [A.OnlyP emptyMeta $ A.Skip emptyMeta]])
+  ,doTest (202, A.Seq emptyMeta $ A.Several emptyMeta [A.OnlyP emptyMeta $ A.Skip emptyMeta], [tc0 A.Int], [])
+  ,doTest (203, A.Seq emptyMeta $ A.Several emptyMeta [A.OnlyP emptyMeta $ A.Skip emptyMeta], [tc2 A.OnlyP, tc1 A.Skip],
+    [ADI $ A.OnlyP emptyMeta $ A.Skip emptyMeta, ADI $ A.Skip emptyMeta])
+ ]
+ where
+   doTest :: Data a => (Int, a, [Constr], [AnyDataItem]) -> Test
+   doTest (n,testIn,testFor,testOut) = TestCase $ assertEqual ("testCheckAny " ++ (show n)) testOut (checkTreeForConstr testFor testIn)
+   tc0 :: Data a => a -> Constr
+   tc0 = toConstr
+   tc1 :: Data a => (a0 -> a) -> Constr
+   tc1 f = toConstr (f undefined)
+   tc2 :: Data a => (a0 -> a1 -> a) -> Constr
+   tc2 f = toConstr (f undefined undefined)
 
 --Returns the list of tests:
 tests :: Test
 tests = TestList
  [
    testIsSafeConversion
+   ,testCheckTreeForConstr
  ]
diff --git a/common/TreeUtil.hs b/common/TreeUtil.hs
index 51f997f..0ebc8ad 100644
--- a/common/TreeUtil.hs
+++ b/common/TreeUtil.hs
@@ -16,7 +16,7 @@ You should have received a copy of the GNU General Public License along
 with this program.  If not, see <http://www.gnu.org/licenses/>.
 -}
 
-module TreeUtil (MatchErrors, AnyDataItem(..), Items, castADI, assertPatternMatch, getMatchedItems, mkPattern, tag0, tag1, tag2, tag3, tag4, tag5, tag6, tag7, tag1d, tag2d, tag3d, tag4d, tag5d, tag6d, tag7d, stopCaringPattern, namePattern, nameAndStopCaringPattern) where
+module TreeUtil (MatchErrors, AnyDataItem(..), Items, castADI, assertPatternMatch, getMatchedItems, mkPattern, tag0, tag1, tag2, tag3, tag4, tag5, tag6, tag7, tag1d, tag2d, tag3d, tag4d, tag5d, tag6d, tag7d, stopCaringPattern, namePattern, nameAndStopCaringPattern, checkTreeForConstr) where
 
 import Test.HUnit hiding (State)
 import qualified Data.Map as Map
@@ -308,3 +308,33 @@ tag6d x = tag6 x DontCare DontCare DontCare DontCare DontCare DontCare
 -- | Like tag7, but with DontCare for all the sub-items
 tag7d :: (Data a) => (a0 -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a) -> Pattern
 tag7d x = tag7 x DontCare DontCare DontCare DontCare DontCare DontCare DontCare
+
+
+-- | Checks that the given tree does not contain any of the constructors supplied.
+-- Returns a list of all tree items matching those constructors
+checkTreeForConstr :: Data a => [Constr] -> a -> [AnyDataItem]
+checkTreeForConstr cons = makeCheckFunction $ zip (map constrType cons) cons
+  where
+    makeCheckFunction :: Data a => [(DataType, Constr)] -> (a -> [AnyDataItem])
+    makeCheckFunction tcs = listify' (anyFunc $ ((map makeCheckFunction' tcs) :: [GenericQ Bool]))
+
+    -- anyFunc takes a list of generic queries, and returns a single generic query that ORs the results together
+    -- Note that this is not the same as using foldl and extQ, because extQ deals with type-specific cases,
+    -- not generic queries as we have here.
+    anyFunc :: [GenericQ Bool] -> GenericQ Bool
+    anyFunc [] _ = False
+    anyFunc (f:fs) x = (f x) || (anyFunc fs x)
+
+    -- listify expects a type-specific function as its parameter, not a generic query.
+    -- This function only differs from listify by using a generic query, and wrapping the result in an AnyDataItem wrapper.
+    listify' :: GenericQ Bool -> GenericQ [AnyDataItem]
+    listify' f = everything (++) f'
+      where
+        f' :: GenericQ [AnyDataItem]
+        f' x = if (f x) then [ADI x] else []
+
+    -- checks that the DataType and Constr match the given Data item.
+    makeCheckFunction' :: (DataType, Constr) -> (GenericQ Bool)
+    makeCheckFunction' (tr,con) d = (show (dataTypeOf d) == show tr) && (c == con) && (show c == show con)
+      where
+        c = toConstr d