diff --git a/common/FlowGraphTest.hs b/common/FlowGraphTest.hs index 1b43140..9352bbc 100644 --- a/common/FlowGraphTest.hs +++ b/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