1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
{- |
Module : Data.GraphViz.Testing.Instances.Generalised
Description : Generalised dot graph instances for Arbitrary.
Copyright : (c) Ivan Lazar Miljenovic
License : 3-Clause BSD-style
Maintainer : Ivan.Miljenovic@gmail.com
-}
module Data.GraphViz.Testing.Instances.Generalised where
import Data.GraphViz.Testing.Instances.Attributes ()
import Data.GraphViz.Testing.Instances.Common
import Data.GraphViz.Testing.Instances.Helpers ()
import Data.GraphViz.Internal.Util (bool)
import Data.GraphViz.Types.Generalised
import Test.QuickCheck
import Control.Monad (liftM, liftM2, liftM4)
import qualified Data.Sequence as Seq
-- -----------------------------------------------------------------------------
-- Defining Arbitrary instances for the generalised types
instance (Arbitrary n) => Arbitrary (DotGraph n) where
arbitrary = liftM4 DotGraph arbitrary arbitrary arbitrary genDStmts
shrink (DotGraph str dir gid stmts) = map (DotGraph str dir gid)
$ shrinkDStmts stmts
genDStmts :: (Arbitrary n) => Gen (DotStatements n)
genDStmts = sized (arbDS gaGraph True)
genDStmt :: (Arbitrary n) => Gen GlobalAttributes -> Bool
-> Gen (DotStatement n)
genDStmt ga haveSGs = frequency
. bool id ((1,genSG):) haveSGs
$ [ (3, liftM GA ga)
, (5, liftM DN arbitrary)
, (7, liftM DE arbitrary)
]
where
genSG = liftM SG arbitrary
shrinkDStmts :: (Arbitrary n) => DotStatements n -> [DotStatements n]
shrinkDStmts gds
| len == 1 = map Seq.singleton . shrink $ Seq.index gds 0
| otherwise = [gds1, gds2]
where
len = Seq.length gds
-- Halve the sequence
(gds1, gds2) = (len `div` 2) `Seq.splitAt` gds
instance (Arbitrary n) => Arbitrary (DotStatement n) where
arbitrary = genDStmt gaGraph True
shrink (GA ga) = map GA $ shrink ga
shrink (SG sg) = map SG $ shrink sg
shrink (DN dn) = map DN $ shrink dn
shrink (DE de) = map DE $ shrink de
-- | If 'True', generate 'GDotSubGraph's; otherwise don't.
arbDS :: (Arbitrary n) => Gen GlobalAttributes -> Bool -> Int -> Gen (DotStatements n)
arbDS ga haveSGs s = liftM Seq.fromList . resize s' . listOf $ genDStmt ga haveSGs
where
s' = min s 10
instance (Arbitrary n) => Arbitrary (DotSubGraph n) where
arbitrary = do isClust <- arbitrary
let ga = bool gaSubGraph gaClusters isClust
liftM2 (DotSG isClust) arbitrary (sized $ arbDS ga False)
shrink (DotSG isCl mid stmts) = map (DotSG isCl mid) $ shrinkDStmts stmts
|
