Fixed the broken QuickCheck tests for node replacement

common/FlowGraphTest.hs

@@ -457,7 +457,7 @@ comb4 func list0 list1 list2 list3 = (liftM4 (,,,)) list0 list1 list2 list3 >>*
 -- | Wrapper for Quickcheck.
 -- In order to stop conflict with Quickcheck's in-built rules for things such as pairs
 -- (which do not allow overlapping instances), we have to wrap such types ourself.
-newtype QC a = QC a deriving (Eq, Show)
+newtype QC a = QC a deriving (Eq)
 
 -- | We don't allow size zero for generating trees.
 -- So we cheat by changing the size to 1, if it is 0.
@@ -477,6 +477,9 @@ instance Arbitrary (QC (A.Process, Map.Map [Meta] A.Process)) where
   -- For example, we could have the twiddle functions changing an expression
   -- in the tree.  I don't think this would be of use right now, given what we're testing
 
+instance Show (QC (A.Process, Map.Map [Meta] A.Process)) where
+  show (QC (p,m)) = pshow (p,nub $ concat $ Map.keys m)
+
 -- | A function inside a StateT monad that returns the next unique Id.
 nextIdT :: Monad m => StateT Id m Id
 nextIdT = modify' incId
@@ -499,10 +502,12 @@ oneofL gs = do i <- lift $ choose (0,length gs-1)
 -- that can potentially be replaced, but I'm not sure that is always strictly kept to.  Still, it's
 -- a close enough approximation.
 oneofLS :: [(Int, Int -> GenL a)] -> Int -> GenL a
-oneofLS fs n = oneofL $ applyAll n (filterFuncs n fs)
+oneofLS fs n = oneofL $ applyAll n filtered
   where
+    filtered = filterFuncs n fs
+  
     filterFuncs :: Int -> [(Int, Int -> GenL a)] -> [Int -> GenL a]
-    filterFuncs sz = map snd . filter ((>=) sz . fst)
+    filterFuncs sz = map snd . filter ((<= sz) . fst)
 
 -- | A function that takes a "find" parameter, a "replace" parameter, and returns a monadic function
 -- (for convenience) that performs the check\/replacement.
@@ -606,7 +611,7 @@ class ReplicatorAnnotation a where
   replicatorItem :: (Int, Int -> GenL a) -> Maybe (Int, Int -> GenL (A.Structured a))
 
 replicatorItem' :: (ReplicatorAnnotation a, Data a) => (Int, Int -> GenL a) -> (Int, Int -> GenL (A.Structured a))
-replicatorItem' x = (4, genElem3 A.Rep m genReplicator . genStructured x . sub3)
+replicatorItem' x = (4, comb2 (A.Rep emptyMeta) genReplicator . genStructured x . sub3)
 
    --Replicators are allowed in ALTs, IFs, SEQs and PARs:
 instance ReplicatorAnnotation A.Process where replicatorItem = Just . replicatorItem'
@@ -624,11 +629,15 @@ genStructured (no,genOnly) n = nextIdT >>* makeMeta' >>= \m -> (flip oneofLS) n
    ,cond (onlyC allowed) (3,comb2 (\e p -> A.Only emptyMeta $ A.Choice emptyMeta e p) genExpression . genProcess . sub2)
    ,cond (onlyA allowed) (4,genElem2 A.Only m . genAlternative . sub1 )
 -}   
-   (no + 1, genElem2 A.Only m . genOnly . sub1)
+   -- As below, we subtract one to ensure termination
+   (no + 1, comb1 (A.Only m) . genOnly . sub1)
 
    -- Specs currently don't work with Case statements TODO
    ,(3,genElem3 A.Spec m genSpecification . genStructured (no, genOnly) . sub2 )
-   ,(1,genElem2 A.Several m . genList (genStructured (no, genOnly)) . sub1)
+   
+   -- We don't have to subtract 1 here, but we do to ensure test termination
+   -- Otherwise we could infinitely nest Seqs with Severals with Only Seqs with Severals...
+   ,(1,comb1 (A.Several emptyMeta) . genList (genStructured (no, genOnly)) . sub1)
   ] ++ maybeToList (replicatorItem (no,genOnly)) )
 
 -- | Generates a A.Process.
@@ -637,11 +646,11 @@ genProcess n = nextIdT >>* makeMeta' >>= \m -> (flip oneofLS) n
   [
     (1,const $ genElem1 A.Skip m)
    ,(1,const $ genElem1 A.Stop m)
-   ,(2,genElem2 A.Seq m . genStructured genProcess' . sub1)
-   ,(2,genElem3 A.Par m (comb0 A.PlainPar) . genStructured genProcess' . sub1)
+   ,(1,comb1 (A.Seq emptyMeta) . genStructured genProcess')
+   ,(1,comb1 (A.Par emptyMeta A.PlainPar) . genStructured genProcess')
    ,(3,genElem3 A.While m genExpression . genProcess . sub2)
-   ,(2,genElem2 A.If m . genStructured genChoice' . sub1)
-   ,(3,genElem3 A.Case m genExpression . genStructured genOption' . sub2)
+   ,(1,comb1 (A.If emptyMeta) . genStructured genChoice')
+   ,(2,comb2 (A.Case emptyMeta) genExpression . genStructured genOption' . sub1)
    ,(2,const $ genElem3 A.Assign m (comb0 [variable "x"]) genExpressionList)
    ,(1,const $ genElem2 A.GetTime m (comb0 $ variable "x"))
    ,(1,const $ genElem3 A.Wait m (comb0 A.WaitFor) genExpression)
@@ -677,7 +686,7 @@ pickFuncId g = map (applyFunc . getFunc) (labNodes g)
 -- | Given a flow-graph, it returns a list of the meta-tag replacement alteration functions,
 -- for each meta-tag (i.e. each node).
 pickFuncRep :: (Data a, Monad m) => FlowGraph' m () a -> Map.Map Meta (A.Structured a -> m (A.Structured a))
-pickFuncRep gr = Map.fromList $ map (helpApplyFunc . getMetaFunc) (labNodes gr)
+pickFuncRep gr = Map.fromList $ filter ((/= emptyMeta) . fst) $ map (helpApplyFunc . getMetaFunc) (labNodes gr)
   where
     getMetaFunc (_,n) = (getNodeMeta n,getNodeFunc n)
     
@@ -688,9 +697,9 @@ pickFuncRep gr = Map.fromList $ map (helpApplyFunc . getMetaFunc) (labNodes gr)
     applyFunc (m,AlterExpressionList f) = f (g m)
     applyFunc (m,AlterReplicator f) = f (g m)
     applyFunc (m,AlterSpec f) = f (g m)
-    applyFunc (m,AlterNothing) = g m
+    applyFunc (m,AlterNothing) = return
     
-    g m = everywhereM (mkM $ replaceM m (replaceMeta m))
+    g m = gmapM (mkM $ replaceM m (replaceMeta m))
 
 
 -- | It is important to have these functions in the right ratio.  The number of possible trees is
@@ -728,7 +737,8 @@ testModify =
     -- produces the expected result.
     prop_Rep :: QC (A.Process, Map.Map [Meta] A.Process) -> QCProp
     prop_Rep (QC (g,rest)) = sequence_ $ (flip map) (helper $ pickFuncRep $ genGraph g') $ 
-        \(funcs,ms) -> Just (runIdentity (applyMetas ms funcs g')) *==* (Map.lookup ms rest >>* A.Only emptyMeta)
+        \(funcs,ms) -> testEqual (show ms)
+          (Just (runIdentity (applyMetas ms funcs g'))) (Map.lookup ms rest >>* A.Only emptyMeta)
       where
         g' = A.Only emptyMeta g