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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE OverloadedStrings #-}
{- |
Module : Data.GraphViz.Testing.Instances.Helpers
Description : Helper functions for graphviz Arbitrary instances.
Copyright : (c) Ivan Lazar Miljenovic
License : 3-Clause BSD-style
Maintainer : Ivan.Miljenovic@gmail.com
-}
module Data.GraphViz.Testing.Instances.Helpers where
import Data.GraphViz.Internal.State (initialState, layerListSep, layerSep)
import Data.GraphViz.Parsing (isNumString)
import Test.QuickCheck
import Control.Monad (liftM, liftM2)
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
-- -----------------------------------------------------------------------------
-- Helper Functions
instance Arbitrary Text where
arbitrary = arbText
shrink = filter validString
. map T.pack . nonEmptyShrinks' . T.unpack
arbText :: Gen Text
arbText = suchThat genStr notBool
where
genStr = liftM2 T.cons (elements notDigits)
(liftM T.concat . listOf $ elements strChr)
notDigits = ['a'..'z'] ++ ['\'', '"', ' ', '(', ')', ',', ':', '\\']
strChr = map T.singleton $ notDigits ++ '.' : ['0'..'9']
arbString :: Gen String
arbString = liftM T.unpack arbitrary
fromPositive :: Positive a -> a
fromPositive (Positive a) = a
posArbitrary :: (Arbitrary a, Num a, Ord a) => Gen a
posArbitrary = liftM fromPositive arbitrary
arbIDString :: Gen Text
arbIDString = suchThat genStr notBool
where
genStr = liftM2 T.cons (elements frst)
(liftM T.pack . listOf $ elements rest)
frst = ['a'..'z'] ++ ['_']
rest = frst ++ ['0'.. '9']
validString :: Text -> Bool
validString = liftM2 (&&) notBool notNumStr
notBool :: Text -> Bool
notBool "true" = False
notBool "false" = False
notBool _ = True
shrinkString :: String -> [String]
shrinkString = map T.unpack . shrink . T.pack
notNumStr :: Text -> Bool
notNumStr = not . isNumString
arbBounded :: (Bounded a, Enum a) => Gen a
arbBounded = elements [minBound .. maxBound]
arbLayerName :: Gen Text
arbLayerName = suchThat arbitrary (T.all notLayerSep)
where
defLayerSep = layerSep initialState ++ layerListSep initialState
notLayerSep = (`notElem` defLayerSep)
arbStyleName :: Gen Text
arbStyleName = suchThat arbitrary (T.all notBrackCom)
where
notBrackCom = flip notElem ['(', ')', ',', ' ']
arbList :: (Arbitrary a) => Gen [a]
arbList = listOf1 arbitrary
nonEmptyShrinks :: (Arbitrary a) => [a] -> [[a]]
nonEmptyShrinks = filter (not . null) . shrink
nonEmptyShrinks' :: [a] -> [[a]]
nonEmptyShrinks' = filter (not . null) . listShrink'
-- Shrink lists with more than one value only by removing values, not
-- by shrinking individual items.
listShrink :: (Arbitrary a) => [a] -> [[a]]
listShrink [a] = map return $ shrink a
listShrink as = listShrink' as
-- Just shrink the size.
listShrink' :: [a] -> [[a]]
listShrink' as = rm (length as) as
where
rm 0 _ = []
rm 1 _ = [[]]
rm n xs = xs1
: xs2
: ( [ xs1' ++ xs2 | xs1' <- rm n1 xs1, not (null xs1') ]
`ilv` [ xs1 ++ xs2' | xs2' <- rm n2 xs2, not (null xs2') ]
)
where
n1 = n `div` 2
xs1 = take n1 xs
n2 = n - n1
xs2 = drop n1 xs
[] `ilv` ys = ys
xs `ilv` [] = xs
(x:xs) `ilv` (y:ys) = x : y : (xs `ilv` ys)
-- When a Maybe value is a sub-component, and we need shrink to return
-- a value.
shrinkM :: (Arbitrary a) => Maybe a -> [Maybe a]
shrinkM Nothing = [Nothing]
shrinkM j = shrink j
shrinkL :: (Arbitrary a) => [a] -> [[a]]
shrinkL xs = case listShrink xs of
[] -> [xs]
xs' -> xs'
notInt :: Double -> Bool
notInt d = fromIntegral (round d :: Int) /= d
returnCheck :: (Eq a) => a -> a -> [a]
returnCheck o n = if o == n
then []
else [n]
|
