@@ -0,0 +1,847 @@
1+{-# LANGUAGE QuasiQuotes #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+module Main where
4+
5+import Graphics.Vty.Attributes
6+import Graphics.Vty.Image
7+import Graphics.Vty.Picture
8+import Graphics.Vty.Terminal
9+import Graphics.Vty.WinRegion
10+
11+import Control.Monad
12+
13+import Data.List ( lookup )
14+import Data.Maybe ( isJust, fromJust )
15+import Data.Monoid
16+import Data.Word
17+
18+import Foreign.Marshal.Array
19+import HereDoc
20+
21+import qualified System.Environment as Env
22+
23+import System.IO ( hFlush, hPutStr, hPutBuf, stdout )
24+
25+main = do
26+ print_intro
27+
28+output_file_path = "test_results.list"
29+
30+print_intro = do
31+ putStr $ [$heredoc|
32+This is an interactive verification program for the terminal input and output
33+support of the VTY library. This will ask a series of questions about what you
34+see onscreen. The goal is to verify that VTY's output and input support
35+performs as expected with your terminal.
36+
37+This program produces a file named
38+ |] ++ output_file_path ++ [$heredoc|
39+in the current directory that contains the results for each test assertion. This
40+can be emailed to coreyoconnor@gmail.com and used by the VTY authors to improve
41+support for your terminal. No personal information is contained in the report.
42+
43+Each test follows, more or less, the following format:
44+ 0. A description of the test is printed which will include a detailed
45+ description of what VTY is going to try and what the expected results are.
46+ Press return to move on.
47+ 1. The program will produce some output or ask for you to press a key.
48+ 2. You will then be asked to confirm if the behavior matched the provided
49+ description. Just pressing enter implies the default response that
50+ everything was as expected.
51+
52+All the tests assume the following about the terminal display:
53+ 0. The terminal display will not be resized during a test and is at least 80
54+ characters in width.
55+ 1. The terminal display is using a monospaced font for both single width and
56+ double width characters.
57+ 2. A double width character is displayed with exactly twice the width of a
58+ single column character. This may require adjusting the font used by the
59+ terminal. At least, that is the case using xterm.
60+ 3. Fonts are installed, and usable by the terminal, that define glyphs for
61+ a good range of the unicode characters. Each test involving unicode display
62+ describes the expected appearance of each glyph.
63+
64+Thanks for the help! :-D
65+|]
66+ wait_for_return
67+ results <- do_test_menu 1
68+ env_attributes <- mapM ( \env_name -> catch ( Env.getEnv env_name >>= return . (,) env_name )
69+ ( const $ return (env_name, "") )
70+ )
71+ [ "TERM", "COLORTERM", "LANG" ]
72+ let results_txt = show env_attributes ++ "\n" ++ show results ++ "\n"
73+ writeFile output_file_path results_txt
74+
75+wait_for_return = do
76+ putStr "\n(press return to continue)"
77+ hFlush stdout
78+ getLine
79+
80+test_menu :: [(String, Test)]
81+test_menu = zip (map show [1..]) all_tests
82+
83+do_test_menu :: Int -> IO [(String, Bool)]
84+do_test_menu next_ID
85+ | next_ID > length all_tests = do
86+ putStrLn $ "Done! Please email the " ++ output_file_path ++ " file to coreyoconnor@gmail.com"
87+ return []
88+ | otherwise = do
89+ display_test_menu
90+ putStrLn $ "Press return to start with #" ++ show next_ID ++ "."
91+ putStrLn "Enter a test number to perform only that test."
92+ putStrLn "q (or control-C) to quit."
93+ putStr "> "
94+ hFlush stdout
95+ s <- getLine >>= return . filter (/= '\n')
96+ case s of
97+ "q" -> return mempty
98+ "" -> do
99+ r <- run_test $ show next_ID
100+ rs <- do_test_menu ( next_ID + 1 )
101+ return $ r : rs
102+ i | isJust ( lookup i test_menu ) -> do
103+ r <- run_test i
104+ rs <- do_test_menu ( read i + 1 )
105+ return $ r : rs
106+ where
107+ display_test_menu
108+ = mapM_ display_test_menu' test_menu
109+ display_test_menu' ( i, t )
110+ = putStrLn $ ( if i == show next_ID
111+ then "> "
112+ else " "
113+ ) ++ i ++ ". " ++ test_name t
114+
115+run_test :: String -> IO (String, Bool)
116+run_test i = do
117+ let t = fromJust $ lookup i test_menu
118+ print_summary t
119+ wait_for_return
120+ test_action t
121+ r <- confirm_results t
122+ return (test_ID t, r)
123+
124+default_success_confirm_results = do
125+ putStr "\n"
126+ putStr "[Y/n] "
127+ hFlush stdout
128+ r <- getLine
129+ case r of
130+ "" -> return True
131+ "y" -> return True
132+ "Y" -> return True
133+ "n" -> return False
134+
135+data Test = Test
136+ { test_name :: String
137+ , test_ID :: String
138+ , test_action :: IO ()
139+ , print_summary :: IO ()
140+ , confirm_results :: IO Bool
141+ }
142+
143+all_tests
144+ = [ reserve_output_test
145+ , display_bounds_test_0
146+ , display_bounds_test_1
147+ , display_bounds_test_2
148+ , display_bounds_test_3
149+ , unicode_single_width_0
150+ , unicode_single_width_1
151+ , unicode_double_width_0
152+ , unicode_double_width_1
153+ , attributes_test_0
154+ , attributes_test_1
155+ , attributes_test_2
156+ , attributes_test_3
157+ , attributes_test_4
158+ , attributes_test_5
159+ ]
160+
161+reserve_output_test = Test
162+ { test_name = "Initialize and reserve terminal output then restore previous state."
163+ , test_ID = "reserve_output_test"
164+ , test_action = do
165+ t <- terminal_handle
166+ reserve_display t
167+ putStrLn "Line 1"
168+ putStrLn "Line 2"
169+ putStrLn "Line 3"
170+ putStrLn "Line 4 (press return)"
171+ hFlush stdout
172+ getLine
173+ release_display t
174+ release_terminal t
175+ return ()
176+ , print_summary = do
177+ putStr $ [$heredoc|
178+Once return is pressed:
179+The screen will be cleared.
180+The cursor should be visible and at the top left corner.
181+Four lines of text should be visible.
182+
183+After enter is pressed for the second time this test then:
184+ * The screen containing the test summary should be restored;
185+ * The cursor is visible.
186+|]
187+ , confirm_results = do
188+ putStr $ [$heredoc|
189+Did the test output match the description?
190+|]
191+ default_success_confirm_results
192+ }
193+
194+display_bounds_test_0 = Test
195+ { test_name = "Verify display bounds are correct test 0: Using spaces."
196+ , test_ID = "display_bounds_test_0"
197+ , test_action = do
198+ t <- terminal_handle
199+ reserve_display t
200+ DisplayBounds w h <- display_bounds t
201+ let row_0 = replicate (fromEnum w) 'X' ++ "\n"
202+ row_h = replicate (fromEnum w - 1) 'X'
203+ row_n = "X" ++ replicate (fromEnum w - 2) ' ' ++ "X\n"
204+ image = row_0 ++ (concat $ replicate (fromEnum h - 2) row_n) ++ row_h
205+ putStr image
206+ hFlush stdout
207+ getLine
208+ release_display t
209+ release_terminal t
210+ return ()
211+ , print_summary = display_bounds_test_summary True
212+ , confirm_results = generic_output_match_confirm
213+ }
214+
215+display_bounds_test_1 = Test
216+ { test_name = "Verify display bounds are correct test 0: Using cursor movement."
217+ , test_ID = "display_bounds_test_1"
218+ , test_action = do
219+ t <- terminal_handle
220+ reserve_display t
221+ DisplayBounds w h <- display_bounds t
222+ set_cursor_pos t 0 0
223+ let row_0 = replicate (fromEnum w) 'X' ++ "\n"
224+ putStr row_0
225+ forM_ [1 .. h - 2] $ \y -> do
226+ set_cursor_pos t 0 y
227+ putStr "X"
228+ set_cursor_pos t (w - 1) y
229+ putStr "X"
230+ set_cursor_pos t 0 (h - 1)
231+ let row_h = replicate (fromEnum w - 1) 'X'
232+ putStr row_h
233+ hFlush stdout
234+ getLine
235+ release_display t
236+ release_terminal t
237+ return ()
238+ , print_summary = display_bounds_test_summary True
239+ , confirm_results = generic_output_match_confirm
240+ }
241+
242+display_bounds_test_2 = Test
243+ { test_name = "Verify display bounds are correct test 0: Using Image ops."
244+ , test_ID = "display_bounds_test_2"
245+ , test_action = do
246+ t <- terminal_handle
247+ reserve_display t
248+ bounds@(DisplayBounds w h) <- display_bounds t
249+ let first_row = horiz_cat $ replicate (fromEnum w) (char def_attr 'X')
250+ middle_rows = vert_cat $ replicate (fromEnum h - 2) middle_row
251+ middle_row = (char def_attr 'X') <|> background_fill (w - 2) 1 <|> (char def_attr 'X')
252+ end_row = first_row
253+ image = first_row <-> middle_rows <-> end_row
254+ pic = (pic_for_image image) { pic_cursor = Cursor (w - 1) (h - 1) }
255+ d <- display_context t bounds
256+ output_picture d pic
257+ getLine
258+ release_display t
259+ release_terminal t
260+ return ()
261+ , print_summary = display_bounds_test_summary True
262+ , confirm_results = generic_output_match_confirm
263+ }
264+
265+display_bounds_test_3 = Test
266+ { test_name = "Verify display bounds are correct test 0: Hide cursor; Set cursor pos."
267+ , test_ID = "display_bounds_test_3"
268+ , test_action = do
269+ t <- terminal_handle
270+ reserve_display t
271+ DisplayBounds w h <- display_bounds t
272+ hide_cursor t
273+ set_cursor_pos t 0 0
274+ let row_0 = replicate (fromEnum w) 'X'
275+ putStrLn row_0
276+ forM_ [1 .. h - 2] $ \y -> do
277+ set_cursor_pos t 0 y
278+ putStr "X"
279+ set_cursor_pos t (w - 1) y
280+ putStr "X"
281+ set_cursor_pos t 0 (h - 1)
282+ let row_h = row_0
283+ putStr row_h
284+ hFlush stdout
285+ getLine
286+ show_cursor t
287+ release_display t
288+ release_terminal t
289+ return ()
290+ , print_summary = display_bounds_test_summary False
291+ , confirm_results = generic_output_match_confirm
292+ }
293+
294+display_bounds_test_summary has_cursor = do
295+ putStr $ [$heredoc|
296+Once return is pressed:
297+ 0. The screen will be cleared.
298+|]
299+ if has_cursor
300+ then putStr " 1. The cursor will be visible."
301+ else putStr " 1. The cursor will NOT be visible."
302+ putStr [$heredoc|
303+ 2. The border of the display will be outlined in Xs.
304+ So if - and | represented the edge of the terminal window:
305+ |-------------|
306+ |XXXXXXXXXXXXX|
307+ |X X||]
308+
309+ if has_cursor
310+ then putStr $ [$heredoc|
311+ |XXXXXXXXXXXXC| |]
312+ else putStr $ [$heredoc|
313+ |XXXXXXXXXXXXX| |]
314+
315+ putStr $ [$heredoc|
316+ |-------------|
317+
318+ ( Where C is the final position of the cursor. There may be an X drawn
319+ under the cursor. )
320+ 3. The display will remain in this state until return is pressed again.
321+
322+After return is pressed for the second time:
323+ 0. The screen containing the test summary should be restored.
324+ 1. The cursor should be visible.
325+|]
326+
327+generic_output_match_confirm = do
328+ putStr $ [$heredoc|
329+Did the test output match the description?
330+|]
331+ default_success_confirm_results
332+
333+-- Explicitely definethe bytes that encode each example text.
334+-- This avoids any issues with how the compiler represents string literals.
335+--
336+-- This document is UTF-8 encoded so the UTF-8 string is still included for
337+-- reference
338+--
339+-- It's assumed the compiler will at least not barf on UTF-8 encoded text in
340+-- comments ;-)
341+--
342+-- txt_0 = ↑↑↓↓←→←→BA
343+
344+utf8_txt_0 :: [[Word8]]
345+utf8_txt_0 = [ [ 0xe2 , 0x86 , 0x91 ]
346+ , [ 0xe2 , 0x86 , 0x91 ]
347+ , [ 0xe2 , 0x86 , 0x93 ]
348+ , [ 0xe2 , 0x86 , 0x93 ]
349+ , [ 0xe2 , 0x86 , 0x90 ]
350+ , [ 0xe2 , 0x86 , 0x92 ]
351+ , [ 0xe2 , 0x86 , 0x90 ]
352+ , [ 0xe2 , 0x86 , 0x92 ]
353+ , [ 0x42 ]
354+ , [ 0x41 ]
355+ ]
356+
357+iso_10464_txt_0 :: String
358+iso_10464_txt_0 = map toEnum
359+ [ 8593
360+ , 8593
361+ , 8595
362+ , 8595
363+ , 8592
364+ , 8594
365+ , 8592
366+ , 8594
367+ , 66
368+ , 65
369+ ]
370+
371+unicode_single_width_0 = Test
372+ { test_name = "Verify terminal can display unicode single-width characters. (Direct UTF-8)"
373+ , test_ID = "unicode_single_width_0"
374+ , test_action = do
375+ t <- terminal_handle
376+ reserve_display t
377+ withArrayLen (concat utf8_txt_0) (flip $ hPutBuf stdout)
378+ hPutStr stdout "\n"
379+ hPutStr stdout "0123456789\n"
380+ hFlush stdout
381+ getLine
382+ release_display t
383+ release_terminal t
384+ return ()
385+ , print_summary = unicode_single_width_summary
386+ , confirm_results = generic_output_match_confirm
387+ }
388+
389+unicode_single_width_1 = Test
390+ { test_name = "Verify terminal can display unicode single-width characters. (Image ops)"
391+ , test_ID = "unicode_single_width_1"
392+ , test_action = do
393+ t <- terminal_handle
394+ reserve_display t
395+ let pic = pic_for_image image
396+ image = line_0 <-> line_1
397+ line_0 = iso_10464_string def_attr iso_10464_txt_0
398+ line_1 = string def_attr "0123456789"
399+ d <- display_bounds t >>= display_context t
400+ output_picture d pic
401+ getLine
402+ release_display t
403+ release_terminal t
404+ return ()
405+ , print_summary = unicode_single_width_summary
406+ , confirm_results = generic_output_match_confirm
407+ }
408+
409+unicode_single_width_summary = putStr [$heredoc|
410+Once return is pressed:
411+ 0. The screen will be cleared.
412+ 1. The cursor will be hidden.
413+ 2. Two horizontal lines of text will be displayed:
414+ a. The first will be a sequence of glyphs in UTF-8 encoding. Each glyph
415+ will occupy one column of space. The order and appearance of the glyphs
416+ will be:
417+ | column | appearance |
418+ ==========================
419+ | 0 | up arrow |
420+ | 1 | up arrow |
421+ | 2 | down arrow |
422+ | 3 | down arrow |
423+ | 4 | left arrow |
424+ | 5 | right arrow |
425+ | 6 | left arrow |
426+ | 7 | right arrow |
427+ | 8 | B |
428+ | 9 | A |
429+ ( see: http://en.wikipedia.org/wiki/Arrow_(symbol) )
430+ b. The second will be: 0123456789.
431+
432+Verify:
433+ * The far right extent of the glyphs on both lines are equal;
434+ * The glyphs are as described.
435+
436+After return is pressed for the second time:
437+ 0. The screen containing the test summary should be restored.
438+ 1. The cursor should be visible.
439+|]
440+
441+-- The second example is a unicode string containing double-width glyphs
442+-- 你好吗
443+utf8_txt_1 :: [[Word8]]
444+utf8_txt_1 = [ [0xe4,0xbd,0xa0]
445+ , [0xe5,0xa5,0xbd]
446+ , [0xe5,0x90,0x97]
447+ ]
448+
449+iso_10464_txt_1 :: String
450+iso_10464_txt_1 = map toEnum [20320,22909,21527]
451+
452+unicode_double_width_0 = Test
453+ { test_name = "Verify terminal can display unicode double-width characters. (Direct UTF-8)"
454+ , test_ID = "unicode_double_width_0"
455+ , test_action = do
456+ t <- terminal_handle
457+ reserve_display t
458+ withArrayLen (concat utf8_txt_1) (flip $ hPutBuf stdout)
459+ hPutStr stdout "\n"
460+ hPutStr stdout "012345\n"
461+ hFlush stdout
462+ getLine
463+ release_display t
464+ release_terminal t
465+ return ()
466+ , print_summary = unicode_double_width_summary
467+ , confirm_results = generic_output_match_confirm
468+ }
469+
470+unicode_double_width_1 = Test
471+ { test_name = "Verify terminal can display unicode double-width characters. (Image ops)"
472+ , test_ID = "unicode_double_width_1"
473+ , test_action = do
474+ t <- terminal_handle
475+ reserve_display t
476+ let pic = pic_for_image image
477+ image = line_0 <-> line_1
478+ line_0 = iso_10464_string def_attr iso_10464_txt_1
479+ line_1 = string def_attr "012345"
480+ d <- display_bounds t >>= display_context t
481+ output_picture d pic
482+ getLine
483+ release_display t
484+ release_terminal t
485+ return ()
486+ , print_summary = unicode_double_width_summary
487+ , confirm_results = generic_output_match_confirm
488+ }
489+
490+unicode_double_width_summary = putStr [$heredoc|
491+Once return is pressed:
492+ 0. The screen will be cleared.
493+ 1. The cursor will be hidden.
494+ 2. Two horizontal lines of text will be displayed:
495+ a. The first will be a sequence of glyphs in UTF-8 encoding. Each glyph
496+ will occupy two columns of space. The order and appearance of the glyphs
497+ will be:
498+ | column | appearance |
499+ ======================================
500+ | 0 | first half of ni3 |
501+ | 1 | second half of ni3 |
502+ | 2 | first half of hao3 |
503+ | 3 | second half of hao3 |
504+ | 4 | first half of ma |
505+ | 5 | second half of ma |
506+ b. The second will be: 012345.
507+
508+Verify:
509+ * The far right extent of the glyphs on both lines are equal;
510+ * The glyphs are as described.
511+
512+After return is pressed for the second time:
513+ 0. The screen containing the test summary should be restored.
514+ 1. The cursor should be visible.
515+|]
516+
517+all_colors = zip [ black, red, green, yellow, blue, magenta, cyan, white, def ]
518+ [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white", "default" ]
519+
520+attributes_test_0 = Test
521+ { test_name = "Character attributes: foreground colors."
522+ , test_ID = "attributes_test_0"
523+ , test_action = do
524+ t <- terminal_handle
525+ reserve_display t
526+ let pic = pic_for_image image
527+ image = border <|> column_0 <|> border <|> column_1 <|> border
528+ column_0 = vert_cat $ map line_with_color all_colors
529+ border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
530+ column_1 = vert_cat $ map (string def_attr . snd) all_colors
531+ line_with_color (c_value, c_name) = string (setFG c_value def_attr) c_name
532+ d <- display_bounds t >>= display_context t
533+ output_picture d pic
534+ getLine
535+ release_display t
536+ release_terminal t
537+ return ()
538+ , print_summary = do
539+ putStr $ [$heredoc|
540+Once return is pressed:
541+ 0. The screen will be cleared.
542+ 1. The cursor will be hidden.
543+ 2. 9 lines of text in two columns will be drawn. The first column will be a
544+ name of a standard color (for an 8 color terminal) rendered in that color.
545+ For instance, one line will be the word "magenta" and that word should be
546+ rendered in the magenta color. The second column will be the name of a
547+ standard color rendered with the default attributes.
548+
549+Verify:
550+ * In the first column: The foreground color matches the named color.
551+ * The second column: All text is rendered with the default attributes.
552+ * The vertical bars used in each line to mark the border of a column are
553+ lined up.
554+
555+After return is pressed for the second time:
556+ 0. The screen containing the test summary should be restored.
557+ 1. The cursor should be visible.
558+|]
559+ , confirm_results = do
560+ putStr $ [$heredoc|
561+Did the test output match the description?
562+|]
563+ default_success_confirm_results
564+ }
565+
566+attributes_test_1 = Test
567+ { test_name = "Character attributes: background colors."
568+ , test_ID = "attributes_test_1"
569+ , test_action = do
570+ t <- terminal_handle
571+ reserve_display t
572+ let pic = pic_for_image image
573+ image = border <|> column_0 <|> border <|> column_1 <|> border
574+ column_0 = vert_cat $ map line_with_color all_colors
575+ border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
576+ column_1 = vert_cat $ map (string def_attr . snd) all_colors
577+ line_with_color (c_value, c_name) = string (setBG c_value def_attr) c_name
578+ d <- display_bounds t >>= display_context t
579+ output_picture d pic
580+ getLine
581+ release_display t
582+ release_terminal t
583+ return ()
584+ , print_summary = do
585+ putStr $ [$heredoc|
586+Once return is pressed:
587+ 0. The screen will be cleared.
588+ 1. The cursor will be hidden.
589+ 2. 9 lines of text in two columns will be drawn. The first column will
590+ contain be a name of a standard color for an 8 color terminal rendered with
591+ the default foreground color with a background the named color. For
592+ instance, one line will contain be the word "magenta" and that words should
593+ be rendered in the default foreground color over a magenta background. The
594+ second column will be the name of a standard color rendered with the default
595+ attributes.
596+
597+Verify:
598+ * The first column: The background color matches the named color.
599+ * The second column: All text is rendered with the default attributes.
600+ * The vertical bars used in each line to mark the border of a column are
601+ lined up.
602+
603+Note: I haven't decided if, in this case, the background color should extend to
604+fills added for alignment. Right now the selected background color is only
605+applied to the background where the word is actually rendered. Since each word
606+is not of the same length VTY adds background fills to make the width of each
607+row effectively the same. These added fills are all currently rendered with the
608+default background pattern.
609+
610+After return is pressed for the second time:
611+ 0. The screen containing the test summary should be restored.
612+ 1. The cursor should be visible.
613+|]
614+ , confirm_results = do
615+ putStr $ [$heredoc|
616+Did the test output match the description?
617+|]
618+ default_success_confirm_results
619+ }
620+
621+attributes_test_2 = Test
622+ { test_name = "Character attributes: Vivid foreground colors."
623+ , test_ID = "attributes_test_2"
624+ , test_action = do
625+ t <- terminal_handle
626+ reserve_display t
627+ let pic = pic_for_image image
628+ image = horiz_cat [border, column_0, border, column_1, border, column_2, border]
629+ border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
630+ column_0 = vert_cat $ map line_with_color_0 all_colors
631+ column_1 = vert_cat $ map line_with_color_1 all_colors
632+ column_2 = vert_cat $ map (string def_attr . snd) all_colors
633+ line_with_color_0 (c_value, c_name) = string (setFG c_value def_attr) c_name
634+ line_with_color_1 (c_value, c_name) = string (setFGVivid c_value def_attr) c_name
635+ d <- display_bounds t >>= display_context t
636+ output_picture d pic
637+ getLine
638+ release_display t
639+ release_terminal t
640+ return ()
641+ , print_summary = do
642+ putStr $ [$heredoc|
643+Once return is pressed:
644+ 0. The screen will be cleared.
645+ 1. The cursor will be hidden.
646+ 2. 9 lines of text in three columns will be drawn:
647+ a. The first column will be a name of a standard color (for an 8 color
648+ terminal) rendered with that color as the foreground color.
649+ b. The next column will be also be the name of a standard color rendered
650+ with that color as the foreground color but the shade used should be
651+ more vivid than the shade used in the first column.
652+ c. The final column will be the name of a color rendered with the
653+ default attributes.
654+
655+For instance, one line will be the word "magenta" and that word should be
656+rendered in the magenta color.
657+
658+I'm not actually sure exactly what "vivid" means in this context. For xterm the
659+vivid colors are brighter.
660+
661+Verify:
662+ * The first column: The foreground color matches the named color.
663+ * The second column: The foreground color matches the named color but is
664+ more vivid than the color used in the first column.
665+ * The third column: All text is rendered with the default attributes.
666+ * The vertical bars used in each line to mark the border of a column are
667+ lined up.
668+
669+After return is pressed for the second time:
670+ 0. The screen containing the test summary should be restored.
671+ 1. The cursor should be visible.
672+|]
673+ , confirm_results = do
674+ putStr $ [$heredoc|
675+Did the test output match the description?
676+|]
677+ default_success_confirm_results
678+ }
679+
680+attributes_test_3 = Test
681+ { test_name = "Character attributes: vivid background colors."
682+ , test_ID = "attributes_test_3"
683+ , test_action = do
684+ t <- terminal_handle
685+ reserve_display t
686+ let pic = pic_for_image image
687+ image = horiz_cat [border, column_0, border, column_1, border, column_2, border]
688+ border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
689+ column_0 = vert_cat $ map line_with_color_0 all_colors
690+ column_1 = vert_cat $ map line_with_color_1 all_colors
691+ column_2 = vert_cat $ map (string def_attr . snd) all_colors
692+ line_with_color_0 (c_value, c_name) = string (setBG c_value def_attr) c_name
693+ line_with_color_1 (c_value, c_name) = string (setBGVivid c_value def_attr) c_name
694+ d <- display_bounds t >>= display_context t
695+ output_picture d pic
696+ getLine
697+ release_display t
698+ release_terminal t
699+ return ()
700+ , print_summary = do
701+ putStr $ [$heredoc|
702+Once return is pressed:
703+ 0. The screen will be cleared.
704+ 1. The cursor will be hidden.
705+ 2. 9 lines of text in three columns will be drawn:
706+ a. The first column will contain be a name of a standard color for an 8
707+ color terminal rendered with the default foreground color with a
708+ background the named color.
709+ b. The first column will contain be a name of a standard color for an 8
710+ color terminal rendered with the default foreground color with the
711+ background a vivid version of the named color.
712+ c. The third column will be the name of a standard color rendered with
713+ the default attributes.
714+
715+For instance, one line will contain be the word "magenta" and that words should
716+be rendered in the default foreground color over a magenta background.
717+
718+I'm not actually sure exactly what "vivid" means in this context. For xterm the
719+vivid colors are brighter.
720+
721+Verify:
722+ * The first column: The background color matches the named color.
723+ * The second column: The background color matches the named color and is
724+ more vivid than the color used in the first column.
725+ * The third column column: All text is rendered with the default attributes.
726+ * The vertical bars used in each line to mark the border of a column are
727+ lined up.
728+
729+Note: I haven't decided if, in this case, the background color should extend to
730+fills added for alignment. Right now the selected background color is only
731+applied to the background where the word is actually rendered. Since each word
732+is not of the same length VTY adds background fills to make the width of each
733+row effectively the same. These added fills are all currently rendered with the
734+default background pattern.
735+
736+After return is pressed for the second time:
737+ 0. The screen containing the test summary should be restored.
738+ 1. The cursor should be visible.
739+|]
740+ , confirm_results = do
741+ putStr $ [$heredoc|
742+Did the test output match the description?
743+|]
744+ default_success_confirm_results
745+ }
746+
747+attr_combos =
748+ [ ("default", id)
749+ , ("bold", setBold)
750+ , ("blink", setBlink)
751+ , ("underline", setUnderline)
752+ , ("bold + blink", setBlink . setBold)
753+ , ("bold + underline", setUnderline . setBold)
754+ , ("underline + blink", setBlink . setUnderline)
755+ , ("bold + blink + underline", setUnderline . setBlink . setBold)
756+ ]
757+
758+attributes_test_4 = Test
759+ { test_name = "Character attributes: Bold; Blink; Underline."
760+ , test_ID = "attributes_test_4"
761+ , test_action = do
762+ t <- terminal_handle
763+ reserve_display t
764+ let pic = pic_for_image image
765+ image = horiz_cat [border, column_0, border, column_1, border]
766+ border = vert_cat $ replicate (length attr_combos) $ string def_attr " | "
767+ column_0 = vert_cat $ map line_with_attrs attr_combos
768+ column_1 = vert_cat $ map (string def_attr . fst) attr_combos
769+ line_with_attrs (desc, attr_f) = string (attr_f def_attr) desc
770+ d <- display_bounds t >>= display_context t
771+ output_picture d pic
772+ getLine
773+ release_display t
774+ release_terminal t
775+ return ()
776+ , print_summary = do
777+ putStr $ [$heredoc|
778+Once return is pressed:
779+ 0. The screen will be cleared.
780+ 1. The cursor will be hidden.
781+ 2. 8 rows of text in two columns.
782+ The rows will contain the following text:
783+ default
784+ bold
785+ blink
786+ underline
787+ bold + blink
788+ bold + underline
789+ underline + blink
790+ bold + blink + underline
791+ The first column will be rendered with the described attributes. The second
792+ column will be rendered with the default attributes.
793+
794+Verify:
795+ * The vertical bars used in each line to mark the border of a column are
796+ lined up.
797+ * The text in the first column is rendered as described.
798+
799+After return is pressed for the second time:
800+ 0. The screen containing the test summary should be restored.
801+ 1. The cursor should be visible.
802+|]
803+ , confirm_results = do
804+ putStr $ [$heredoc|
805+Did the test output match the description?
806+|]
807+ default_success_confirm_results
808+ }
809+
810+attributes_test_5 = Test
811+ { test_name = "Character attributes: 240 color palette"
812+ , test_ID = "attributes_test_5"
813+ , test_action = do
814+ t <- terminal_handle
815+ reserve_display t
816+ let pic = pic_for_image image
817+ image = vert_cat $ map horiz_cat $ split_color_images color_images
818+ color_images = map (\i -> string (current_attr `with_back_color` Color240 i) " ") [0..239]
819+ split_color_images [] = []
820+ split_color_images is = (take 20 is ++ [string def_attr " "]) : (split_color_images (drop 20 is))
821+ d <- display_bounds t >>= display_context t
822+ output_picture d pic
823+ getLine
824+ release_display t
825+ release_terminal t
826+ return ()
827+ , print_summary = do
828+ putStr $ [$heredoc|
829+Once return is pressed:
830+ 0. The screen will be cleared.
831+ 1. The cursor will be hidden.
832+ 2. A 20 character wide and 12 row high block of color squares. This should look like a palette
833+ of some sort. I'm not exactly sure if all color terminals use the same palette. I doubt it...
834+
835+Verify:
836+
837+After return is pressed for the second time:
838+ 0. The screen containing the test summary should be restored.
839+ 1. The cursor should be visible.
840+|]
841+ , confirm_results = do
842+ putStr $ [$heredoc|
843+Did the test output match the description?
844+|]
845+ default_success_confirm_results
846+ }
847+