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
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
|
{-# OPTIONS_GHC -fno-warn-orphans #-}
module NormalizationSpec (spec) where
import Test.Hspec
import Test.QuickCheck
import Data.Word (Word8)
import Blessings
--------------------------------------------------------------------------------
-- Arbitrary instances
--------------------------------------------------------------------------------
instance Arbitrary FColor where
arbitrary =
oneof
[ ECMA48FColor <$> elements ([30..37] <> [90..97] <> [39])
, Xterm256FColor <$> arbitrary
, ISO8613_3FColor <$> arbitrary <*> arbitrary <*> arbitrary
]
instance Arbitrary BColor where
arbitrary =
oneof
[ ECMA48BColor <$> elements ([40..47] <> [49])
, Xterm256BColor <$> arbitrary
, ISO8613_3BColor <$> arbitrary <*> arbitrary <*> arbitrary
]
instance Arbitrary Blink where
arbitrary = elements [Blink, NoBlink]
instance Arbitrary Bold where
arbitrary = elements [Bold, NoBold]
instance Arbitrary Underline where
arbitrary = elements [Underline, NoUnderline]
instance Arbitrary Style where
arbitrary =
Style <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
instance Arbitrary (Blessings String) where
arbitrary = sized genBlessings
where
genBlessings 0 =
oneof
[ pure Empty
, Plain <$> arbitrary
]
genBlessings n =
oneof
[ pure Empty
, Plain <$> arbitrary
, SGR <$> arbitraryPm <*> genBlessings (n `div` 2)
, Append <$> genBlessings (n `div` 2) <*> genBlessings (n `div` 2)
]
arbitraryPm :: Gen [Word8]
arbitraryPm = listOf arbitrary
shrink = shrinkBlessings
shrinkBlessings :: Blessings String -> [Blessings String]
shrinkBlessings = \case
Empty -> []
Plain s -> Empty : [ Plain s' | s' <- shrink s ]
SGR pm a ->
[a] <>
[ SGR pm' a | pm' <- shrinkList (const []) pm ] <>
[ SGR pm a' | a' <- shrinkBlessings a ]
Append a b ->
[a, b] <>
[ Append a' b | a' <- shrinkBlessings a ] <>
[ Append a b' | b' <- shrinkBlessings b ]
--------------------------------------------------------------------------------
-- Helpers
--------------------------------------------------------------------------------
allSgrNodes :: Blessings String -> [(Style, [Word8])]
allSgrNodes = go defaultStyle
where
go :: Style -> Blessings String -> [(Style, [Word8])]
go st = \case
Empty -> []
Plain _ -> []
Append a b -> go st a ++ go st b
SGR pm a ->
let st' = applyPm st pm
in (st, pm) : go st' a
allPm :: Blessings String -> [[Word8]]
allPm = \case
Empty -> []
Plain _ -> []
Append a b -> allPm a ++ allPm b
SGR pm a -> pm : allPm a
size :: Blessings String -> Int
size = \case
Empty -> 1
Plain _ -> 1
SGR _ a -> 1 + size a
Append a b -> 1 + size a + size b
--------------------------------------------------------------------------------
-- Properties
--------------------------------------------------------------------------------
prop_normalize_preserves_sem :: Blessings String -> Bool
prop_normalize_preserves_sem x =
sem (normalize x) == sem x
prop_normalize_idempotent :: Blessings String -> Bool
prop_normalize_idempotent x =
normalize (normalize x) == normalize x
prop_no_unproductive_sgrs :: Blessings String -> Bool
prop_no_unproductive_sgrs x =
all productive (allSgrNodes (normalize x))
where
productive (st, pm) = pmHasVisibleEffect st pm
prop_sgr_params_canonical :: Blessings String -> Bool
prop_sgr_params_canonical x =
all (\pm -> pm == normalizePm pm) (allPm (normalize x))
where
normalizePm pm = styleToPm (applyPm defaultStyle pm)
prop_no_resets :: Blessings String -> Bool
prop_no_resets x =
all (not . elem 0) (allPm (normalize x))
prop_pmHasVisibleEffect_correct :: Style -> [Word8] -> Bool
prop_pmHasVisibleEffect_correct st pm =
pmHasVisibleEffect st pm == (applyPm st pm /= st)
prop_normalize_shrinks_or_equal :: Blessings String -> Bool
prop_normalize_shrinks_or_equal x =
size (normalize x) <= size x
prop_append_sem_associative
:: Blessings String -> Blessings String -> Blessings String -> Bool
prop_append_sem_associative a b c =
sem (Append (Append a b) c) == sem (Append a (Append b c))
--------------------------------------------------------------------------------
-- Test runner
--------------------------------------------------------------------------------
spec :: Spec
spec = do
describe "normalize" $ do
it "preserves semantics" $
property prop_normalize_preserves_sem
it "is idempotent" $
property prop_normalize_idempotent
it "never increases size" $
property prop_normalize_shrinks_or_equal
it "removes all unproductive SGRs" $
property prop_no_unproductive_sgrs
it "produces canonical SGR parameter lists" $
property prop_sgr_params_canonical
it "produces no resets" $
property prop_no_resets
describe "SGR semantics" $ do
it "pmHasVisibleEffect matches style change" $
property prop_pmHasVisibleEffect_correct
describe "Append" $ do
it "is associative under semantics" $
property prop_append_sem_associative
|
