@@ -2,41 +2,42 @@
22{-# LANGUAGE ScopedTypeVariables #-}
33module Main where
44
5+import Graphics.Vty
56import Graphics.Vty.Attributes
6−import Graphics.Vty.Image
77import Graphics.Vty.Inline
88import Graphics.Vty.Picture
9−import Graphics.Vty.Terminal
10−import Graphics.Vty.DisplayRegion
9+import Graphics.Vty.Output
1110
11+import Control.Concurrent (threadDelay)
12+import Control.Exception
1213import Control.Monad
1314
1415import Data.List ( lookup )
1516import Data.Maybe ( isJust, fromJust )
1617import Data.Monoid
18+import Data.String.QQ
1719import Data.Word
1820
19−import Foreign.Marshal.Array
20−import HereDoc
21+import Foreign.Marshal.Array
2122
2223import qualified System.Environment as Env
2324
2425import System.IO ( hFlush, hPutStr, hPutBuf, stdout )
2526
2627main = do
27− print_intro
28+ printIntro
2829
29−output_file_path = "test_results.list"
30+outputFilePath = "test_results.list"
3031
31−print_intro = do
32− putStr $ [$heredoc|
32+printIntro = do
33+ putStr $ [s|
3334This is an interactive verification program for the terminal input and output
3435support of the VTY library. This will ask a series of questions about what you
3536see on screen. The goal is to verify that VTY's output and input support
3637performs as expected with your terminal.
3738
3839This program produces a file named
39− |] ++ output_file_path ++ [$heredoc|
40+ |] ++ outputFilePath ++ [s|
4041in the current directory that contains the results for each test assertion. This
4142can be emailed to coreyoconnor@gmail.com and used by the VTY authors to improve
4243support for your terminal. No personal information is contained in the report.
@@ -62,42 +63,43 @@ All the tests assume the following about the terminal display:
6263 a good range of the unicode characters. Each test involving unicode display
6364 describes the expected appearance of each glyph.
6465
65−Thanks for the help! :-D
66−To exit the test early enter "q" anytime at the following menu screen. Even if
67−you exit the test early please email the test_results.list file to
68−coreyoconnor@gmail.com. The results file will still contain information useful
69−to debug terminal support.
70−
71−|]
72− wait_for_return
73− results <- do_test_menu 1
74− env_attributes <- mapM ( \env_name -> catch ( Env.getEnv env_name >>= return . (,) env_name )
75− ( const $ return (env_name, "") )
76− )
77− [ "TERM", "COLORTERM", "LANG", "TERM_PROGRAM", "XTERM_VERSION" ]
78− t <- terminal_handle
79− let results_txt = show env_attributes ++ "\n"
80− ++ terminal_ID t ++ "\n"
81− ++ show results ++ "\n"
82− release_terminal t
83− writeFile output_file_path results_txt
84−
85−wait_for_return = do
66+Thanks for the help! :-D
67+To exit the test early enter "q" anytime at the following menu screen.
68+
69+If any test fails then please post an issue to
70+ https://github.com/coreyoconnor/vty/issues
71+with the test_results.list file pasted into the issue. A suitable summary is:
72+"interactive terminal test failure".
73+|]
74+ waitForReturn
75+ results <- doTestMenu 1
76+ envAttributes <- mapM ( \envName -> Control.Exception.catch ( Env.getEnv envName >>= return . (,) envName )
77+ ( \ (_ :: SomeException) -> return (envName, "") )
78+ )
79+ [ "TERM", "COLORTERM", "LANG", "TERM_PROGRAM", "XTERM_VERSION" ]
80+ t <- standardIOConfig >>= outputForConfig
81+ let resultsTxt = show envAttributes ++ "\n"
82+ ++ terminalID t ++ "\n"
83+ ++ show results ++ "\n"
84+ releaseTerminal t
85+ writeFile outputFilePath resultsTxt
86+
87+waitForReturn = do
8688 putStr "\n(press return to continue)"
8789 hFlush stdout
8890 getLine
8991
90−test_menu :: [(String, Test)]
91−test_menu = zip (map show [1..]) all_tests
92+testMenu :: [(String, Test)]
93+testMenu = zip (map show [1..]) allTests
9294
93−do_test_menu :: Int -> IO [(String, Bool)]
94−do_test_menu next_ID
95− | next_ID > length all_tests = do
96− putStrLn $ "Done! Please email the " ++ output_file_path ++ " file to coreyoconnor@gmail.com"
95+doTestMenu :: Int -> IO [(String, Bool)]
96+doTestMenu nextID
97+ | nextID > length allTests = do
98+ putStrLn $ "Done! Please email the " ++ outputFilePath ++ " file to coreyoconnor@gmail.com"
9799 return []
98100 | otherwise = do
99− display_test_menu
100− putStrLn $ "Press return to start with #" ++ show next_ID ++ "."
101+ displayTestMenu
102+ putStrLn $ "Press return to start with #" ++ show nextID ++ "."
101103 putStrLn "Enter a test number to perform only that test."
102104 putStrLn "q (or control-C) to quit."
103105 putStr "> "
@@ -105,91 +107,102 @@ do_test_menu next_ID
105107 s <- getLine >>= return . filter (/= '\n')
106108 case s of
107109 "q" -> return mempty
108− "" -> do
109− r <- run_test $ show next_ID
110− rs <- do_test_menu ( next_ID + 1 )
110+ "" -> do
111+ r <- runTest $ show nextID
112+ rs <- doTestMenu ( nextID + 1 )
111113 return $ r : rs
112− i | isJust ( lookup i test_menu ) -> do
113− r <- run_test i
114− rs <- do_test_menu ( read i + 1 )
114+ i | isJust ( lookup i testMenu ) -> do
115+ r <- runTest i
116+ rs <- doTestMenu ( read i + 1 )
115117 return $ r : rs
116118 where
117− display_test_menu
118− = mapM_ display_test_menu' test_menu
119− display_test_menu' ( i, t )
120− = putStrLn $ ( if i == show next_ID
121− then "> "
119+ displayTestMenu
120+ = mapM_ displayTestMenu' testMenu
121+ displayTestMenu' ( i, t )
122+ = putStrLn $ ( if i == show nextID
123+ then "> "
122124 else " "
123− ) ++ i ++ ". " ++ test_name t
124−
125−run_test :: String -> IO (String, Bool)
126−run_test i = do
127− let t = fromJust $ lookup i test_menu
128− print_summary t
129− wait_for_return
130− test_action t
131− r <- confirm_results t
132− return (test_ID t, r)
133−
134−default_success_confirm_results = do
125+ ) ++ i ++ ". " ++ testName t
126+
127+runTest :: String -> IO (String, Bool)
128+runTest i = do
129+ let t = fromJust $ lookup i testMenu
130+ printSummary t
131+ waitForReturn
132+ testAction t
133+ r <- confirmResults t
134+ return (testID t, r)
135+
136+defaultSuccessConfirmResults = do
135137 putStr "\n"
136138 putStr "[Y/n] "
137139 hFlush stdout
138140 r <- getLine
139141 case r of
140− "" -> return True
142+ "" -> return True
141143 "y" -> return True
142144 "Y" -> return True
143145 "n" -> return False
144146
145147data Test = Test
146− { test_name :: String
147− , test_ID :: String
148− , test_action :: IO ()
149− , print_summary :: IO ()
150− , confirm_results :: IO Bool
148+ { testName :: String
149+ , testID :: String
150+ , testAction :: IO ()
151+ , printSummary :: IO ()
152+ , confirmResults :: IO Bool
151153 }
152154
153−all_tests
154− = [ reserve_output_test
155− , display_bounds_test_0
156− , display_bounds_test_1
157− , display_bounds_test_2
158− , display_bounds_test_3
159− , unicode_single_width_0
160− , unicode_single_width_1
161− , unicode_double_width_0
162− , unicode_double_width_1
163− , attributes_test_0
164− , attributes_test_1
165− , attributes_test_2
166− , attributes_test_3
167− , attributes_test_4
168− , attributes_test_5
169− , inline_test_0
170− , inline_test_1
171− , inline_test_2
155+allTests
156+ = [ reserveOutputTest
157+ , displayBoundsTest0
158+ , displayBoundsTest1
159+ , displayBoundsTest2
160+ , displayBoundsTest3
161+ , unicodeSingleWidth0
162+ , unicodeSingleWidth1
163+ , unicodeDoubleWidth0
164+ , unicodeDoubleWidth1
165+ , attributesTest0
166+ , attributesTest1
167+ , attributesTest2
168+ , attributesTest3
169+ , attributesTest4
170+ , attributesTest5
171+ , inlineTest0
172+ , inlineTest1
173+ , inlineTest2
174+ , cursorHideTest0
175+ , vertCropTest0
176+ , vertCropTest1
177+ , vertCropTest2
178+ , vertCropTest3
179+ , horizCropTest0
180+ , horizCropTest1
181+ , horizCropTest2
182+ , horizCropTest3
183+ , layer0
184+ , layer1
172185 ]
173186
174−reserve_output_test = Test
175− { test_name = "Initialize and reserve terminal output then restore previous state."
176− , test_ID = "reserve_output_test"
177− , test_action = do
178− t <- terminal_handle
179− reserve_display t
187+reserveOutputTest = Test
188+ { testName = "Initialize and reserve terminal output then restore previous state."
189+ , testID = "reserveOutputTest"
190+ , testAction = do
191+ t <- standardIOConfig >>= outputForConfig
192+ reserveDisplay t
180193 putStrLn "Line 1"
181194 putStrLn "Line 2"
182195 putStrLn "Line 3"
183196 putStrLn "Line 4 (press return)"
184197 hFlush stdout
185198 getLine
186− release_display t
187− release_terminal t
199+ releaseDisplay t
200+ releaseTerminal t
188201 return ()
189− , print_summary = do
190− putStr $ [$heredoc|
202+ , printSummary = do
203+ putStr $ [s|
191204Once return is pressed:
192− 0. The screen will be cleared.
205+ 0. The screen will be cleared.
193206 1. Four lines of text should be visible.
194207 1. The cursor should be visible and at the start of the fifth line.
195208
@@ -197,135 +210,143 @@ After return is pressed for the second time this test then:
197210 * The screen containing the test summary should be restored;
198211 * The cursor is visible.
199212|]
200− , confirm_results = do
201− putStr $ [$heredoc|
213+ , confirmResults = do
214+ putStr $ [s|
202215Did the test output match the description?
203216|]
204− default_success_confirm_results
217+ defaultSuccessConfirmResults
205218 }
206219
207−display_bounds_test_0 = Test
208− { test_name = "Verify display bounds are correct test 0: Using spaces."
209− , test_ID = "display_bounds_test_0"
210− , test_action = do
211− t <- terminal_handle
212− reserve_display t
213− DisplayRegion w h <- display_bounds t
214− let row_0 = replicate (fromEnum w) 'X' ++ "\n"
215− row_h = replicate (fromEnum w - 1) 'X'
216− row_n = "X" ++ replicate (fromEnum w - 2) ' ' ++ "X\n"
217− image = row_0 ++ (concat $ replicate (fromEnum h - 2) row_n) ++ row_h
220+displayBoundsTest0 = Test
221+ { testName = "Verify display bounds are correct test 0: Using spaces."
222+ , testID = "displayBoundsTest0"
223+ , testAction = do
224+ t <- standardIOConfig >>= outputForConfig
225+ reserveDisplay t
226+ (w,h) <- displayBounds t
227+ let row0 = replicate (fromEnum w) 'X' ++ "\n"
228+ rowH = replicate (fromEnum w - 1) 'X'
229+ rowN = "X" ++ replicate (fromEnum w - 2) ' ' ++ "X\n"
230+ image = row0 ++ (concat $ replicate (fromEnum h - 2) rowN) ++ rowH
218231 putStr image
219232 hFlush stdout
220233 getLine
221− release_display t
222− release_terminal t
234+ releaseDisplay t
235+ releaseTerminal t
223236 return ()
224− , print_summary = display_bounds_test_summary True
225− , confirm_results = generic_output_match_confirm
237+ , printSummary = displayBoundsTestSummary True
238+ , confirmResults = genericOutputMatchConfirm
226239 }
227240
228−display_bounds_test_1 = Test
229− { test_name = "Verify display bounds are correct test 0: Using cursor movement."
230− , test_ID = "display_bounds_test_1"
231− , test_action = do
232− t <- terminal_handle
233− reserve_display t
234− DisplayRegion w h <- display_bounds t
235− set_cursor_pos t 0 0
236− let row_0 = replicate (fromEnum w) 'X' ++ "\n"
237− putStr row_0
241+displayBoundsTest1 = Test
242+ { testName = "Verify display bounds are correct test 0: Using cursor movement."
243+ , testID = "displayBoundsTest1"
244+ , testAction = do
245+ t <- standardIOConfig >>= outputForConfig
246+ reserveDisplay t
247+ (w,h) <- displayBounds t
248+ setCursorPos t 0 0
249+ let row0 = replicate (fromEnum w) 'X' ++ "\n"
250+ putStr row0
238251 forM_ [1 .. h - 2] $ \y -> do
239− set_cursor_pos t 0 y
252+ setCursorPos t 0 y
240253 putStr "X"
241− set_cursor_pos t (w - 1) y
254+ hFlush stdout
255+ setCursorPos t (w - 1) y
242256 putStr "X"
243− set_cursor_pos t 0 (h - 1)
244− let row_h = replicate (fromEnum w - 1) 'X'
245− putStr row_h
257+ hFlush stdout
258+ setCursorPos t 0 (h - 1)
259+ let rowH = replicate (fromEnum w - 1) 'X'
260+ putStr rowH
246261 hFlush stdout
247262 getLine
248− release_display t
249− release_terminal t
263+ releaseDisplay t
264+ releaseTerminal t
250265 return ()
251− , print_summary = display_bounds_test_summary True
252− , confirm_results = generic_output_match_confirm
266+ , printSummary = displayBoundsTestSummary True
267+ , confirmResults = genericOutputMatchConfirm
253268 }
254269
255−display_bounds_test_2 = Test
256− { test_name = "Verify display bounds are correct test 0: Using Image ops."
257− , test_ID = "display_bounds_test_2"
258− , test_action = do
259− t <- terminal_handle
260− reserve_display t
261− bounds@(DisplayRegion w h) <- display_bounds t
262− let first_row = horiz_cat $ replicate (fromEnum w) (char def_attr 'X')
263− middle_rows = vert_cat $ replicate (fromEnum h - 2) middle_row
264− middle_row = (char def_attr 'X') <|> background_fill (w - 2) 1 <|> (char def_attr 'X')
265− end_row = first_row
266− image = first_row <-> middle_rows <-> end_row
267− pic = (pic_for_image image) { pic_cursor = Cursor (w - 1) (h - 1) }
268− d <- display_context t bounds
269− output_picture d pic
270+displayBoundsTest2 = Test
271+ { testName = "Verify display bounds are correct test 0: Using Image ops."
272+ , testID = "displayBoundsTest2"
273+ , testAction = do
274+ t <- standardIOConfig >>= outputForConfig
275+ reserveDisplay t
276+ bounds@(w,h) <- displayBounds t
277+ let firstRow = horizCat $ replicate (fromEnum w) (char defAttr 'X')
278+ middleRows = vertCat $ replicate (fromEnum h - 2) middleRow
279+ middleRow = (char defAttr 'X') <|> backgroundFill (w - 2) 1 <|> (char defAttr 'X')
280+ endRow = firstRow
281+ image = firstRow <-> middleRows <-> endRow
282+ pic = (picForImage image) { picCursor = Cursor (w - 1) (h - 1) }
283+ d <- displayContext t bounds
284+ outputPicture d pic
270285 getLine
271− release_display t
272− release_terminal t
286+ releaseDisplay t
287+ releaseTerminal t
273288 return ()
274− , print_summary = display_bounds_test_summary True
275− , confirm_results = generic_output_match_confirm
289+ , printSummary = displayBoundsTestSummary True
290+ , confirmResults = genericOutputMatchConfirm
276291 }
277292
278−display_bounds_test_3 = Test
279− { test_name = "Verify display bounds are correct test 0: Hide cursor; Set cursor pos."
280− , test_ID = "display_bounds_test_3"
281− , test_action = do
282− t <- terminal_handle
283− reserve_display t
284− DisplayRegion w h <- display_bounds t
285− hide_cursor t
286− set_cursor_pos t 0 0
287− let row_0 = replicate (fromEnum w) 'X'
288− putStrLn row_0
293+displayBoundsTest3 = Test
294+ { testName = "Verify display bounds are correct test 0: Hide cursor; Set cursor pos."
295+ , testID = "displayBoundsTest3"
296+ , testAction = do
297+ t <- standardIOConfig >>= outputForConfig
298+ reserveDisplay t
299+ (w,h) <- displayBounds t
300+ hideCursor t
301+ setCursorPos t 0 0
302+ let row0 = replicate (fromEnum w) 'X'
303+ putStrLn row0
289304 forM_ [1 .. h - 2] $ \y -> do
290− set_cursor_pos t 0 y
305+ setCursorPos t 0 y
291306 putStr "X"
292− set_cursor_pos t (w - 1) y
307+ hFlush stdout
308+ setCursorPos t (w - 1) y
293309 putStr "X"
294− set_cursor_pos t 0 (h - 1)
295− let row_h = row_0
296− putStr row_h
310+ hFlush stdout
311+ setCursorPos t 0 (h - 1)
312+ let rowH = row0
313+ putStr rowH
297314 hFlush stdout
298315 getLine
299− show_cursor t
300− release_display t
301− release_terminal t
316+ showCursor t
317+ releaseDisplay t
318+ releaseTerminal t
302319 return ()
303− , print_summary = display_bounds_test_summary False
304− , confirm_results = generic_output_match_confirm
320+ , printSummary = displayBoundsTestSummary False
321+ , confirmResults = genericOutputMatchConfirm
305322 }
306323
307−display_bounds_test_summary has_cursor = do
308− putStr $ [$heredoc|
324+displayBoundsTestSummary hasCursor = do
325+ putStr $ [s|
309326Once return is pressed:
310327 0. The screen will be cleared.
311328|]
312− if has_cursor
329+ if hasCursor
313330 then putStr " 1. The cursor will be visible."
314331 else putStr " 1. The cursor will NOT be visible."
315− putStr [$heredoc|
332+ putStr [s|
333+
316334 2. The border of the display will be outlined in Xs.
317335 So if - and | represented the edge of the terminal window:
318336 |-------------|
319337 |XXXXXXXXXXXXX|
320338 |X X||]
321339
322− if has_cursor
323− then putStr $ [$heredoc|
340+ if hasCursor
341+ then putStr $ [s|
342+
324343 |XXXXXXXXXXXXC| |]
325− else putStr $ [$heredoc|
344+ else putStr $ [s|
345+
326346 |XXXXXXXXXXXXX| |]
327347
328− putStr $ [$heredoc|
348+ putStr $ [s|
349+
329350 |-------------|
330351
331352 ( Where C is the final position of the cursor. There may be an X drawn
@@ -337,13 +358,13 @@ After return is pressed for the second time:
337358 1. The cursor should be visible.
338359|]
339360
340−generic_output_match_confirm = do
341− putStr $ [$heredoc|
361+genericOutputMatchConfirm = do
362+ putStr $ [s|
342363Did the test output match the description?
343364|]
344− default_success_confirm_results
365+ defaultSuccessConfirmResults
345366
346−-- Explicitely definethe bytes that encode each example text.
367+-- Explicitly define the bytes that encode each example text.
347368-- This avoids any issues with how the compiler represents string literals.
348369--
349370-- This document is UTF-8 encoded so the UTF-8 string is still included for
@@ -352,24 +373,24 @@ Did the test output match the description?
352373-- It's assumed the compiler will at least not barf on UTF-8 encoded text in
353374-- comments ;-)
354375--
355−-- txt_0 = ↑↑↓↓←→←→BA
356−
357−utf8_txt_0 :: [[Word8]]
358−utf8_txt_0 = [ [ 0xe2 , 0x86 , 0x91 ]
359− , [ 0xe2 , 0x86 , 0x91 ]
360− , [ 0xe2 , 0x86 , 0x93 ]
361− , [ 0xe2 , 0x86 , 0x93 ]
362− , [ 0xe2 , 0x86 , 0x90 ]
363− , [ 0xe2 , 0x86 , 0x92 ]
364− , [ 0xe2 , 0x86 , 0x90 ]
365− , [ 0xe2 , 0x86 , 0x92 ]
366− , [ 0x42 ]
367− , [ 0x41 ]
368− ]
369−
370−iso_10646_txt_0 :: String
371−iso_10646_txt_0 = map toEnum
372− [ 8593
376+-- txt0 = ↑↑↓↓←→←→BA
377+
378+utf8Txt0 :: [[Word8]]
379+utf8Txt0 = [ [ 0xe2 , 0x86 , 0x91 ]
380+ , [ 0xe2 , 0x86 , 0x91 ]
381+ , [ 0xe2 , 0x86 , 0x93 ]
382+ , [ 0xe2 , 0x86 , 0x93 ]
383+ , [ 0xe2 , 0x86 , 0x90 ]
384+ , [ 0xe2 , 0x86 , 0x92 ]
385+ , [ 0xe2 , 0x86 , 0x90 ]
386+ , [ 0xe2 , 0x86 , 0x92 ]
387+ , [ 0x42 ]
388+ , [ 0x41 ]
389+ ]
390+
391+iso10646Txt0 :: String
392+iso10646Txt0 = map toEnum
393+ [ 8593
373394 , 8593
374395 , 8595
375396 , 8595
@@ -381,46 +402,46 @@ iso_10646_txt_0 = map toEnum
381402 , 65
382403 ]
383404
384−unicode_single_width_0 = Test
385− { test_name = "Verify terminal can display unicode single-width characters. (Direct UTF-8)"
386− , test_ID = "unicode_single_width_0"
387− , test_action = do
388− t <- terminal_handle
389− reserve_display t
390− hide_cursor t
391− withArrayLen (concat utf8_txt_0) (flip $ hPutBuf stdout)
405+unicodeSingleWidth0 = Test
406+ { testName = "Verify terminal can display unicode single-width characters. (Direct UTF-8)"
407+ , testID = "unicodeSingleWidth0"
408+ , testAction = do
409+ t <- standardIOConfig >>= outputForConfig
410+ reserveDisplay t
411+ hideCursor t
412+ withArrayLen (concat utf8Txt0) (flip $ hPutBuf stdout)
392413 hPutStr stdout "\n"
393414 hPutStr stdout "0123456789\n"
394415 hFlush stdout
395416 getLine
396− release_display t
397− release_terminal t
417+ releaseDisplay t
418+ releaseTerminal t
398419 return ()
399− , print_summary = unicode_single_width_summary
400− , confirm_results = generic_output_match_confirm
420+ , printSummary = unicodeSingleWidthSummary
421+ , confirmResults = genericOutputMatchConfirm
401422 }
402423
403−unicode_single_width_1 = Test
404− { test_name = "Verify terminal can display unicode single-width characters. (Image ops)"
405− , test_ID = "unicode_single_width_1"
406− , test_action = do
407− t <- terminal_handle
408− reserve_display t
409− let pic = pic_for_image image
410− image = line_0 <-> line_1
411− line_0 = iso_10646_string def_attr iso_10646_txt_0
412− line_1 = string def_attr "0123456789"
413− d <- display_bounds t >>= display_context t
414− output_picture d pic
424+unicodeSingleWidth1 = Test
425+ { testName = "Verify terminal can display unicode single-width characters. (Image ops)"
426+ , testID = "unicodeSingleWidth1"
427+ , testAction = do
428+ t <- standardIOConfig >>= outputForConfig
429+ reserveDisplay t
430+ let pic = picForImage image
431+ image = line0 <-> line1
432+ line0 = iso10646String defAttr iso10646Txt0
433+ line1 = string defAttr "0123456789"
434+ d <- displayBounds t >>= displayContext t
435+ outputPicture d pic
415436 getLine
416− release_display t
417− release_terminal t
437+ releaseDisplay t
438+ releaseTerminal t
418439 return ()
419− , print_summary = unicode_single_width_summary
420− , confirm_results = generic_output_match_confirm
440+ , printSummary = unicodeSingleWidthSummary
441+ , confirmResults = genericOutputMatchConfirm
421442 }
422443
423−unicode_single_width_summary = putStr [$heredoc|
444+unicodeSingleWidthSummary = putStr [s|
424445Once return is pressed:
425446 0. The screen will be cleared.
426447 1. The cursor will be hidden.
@@ -454,55 +475,55 @@ After return is pressed for the second time:
454475
455476-- The second example is a unicode string containing double-width glyphs
456477-- 你好吗
457−utf8_txt_1 :: [[Word8]]
458−utf8_txt_1 = [ [0xe4,0xbd,0xa0]
459− , [0xe5,0xa5,0xbd]
460− , [0xe5,0x90,0x97]
461− ]
462−
463−iso_10646_txt_1 :: String
464−iso_10646_txt_1 = map toEnum [20320,22909,21527]
465−
466−unicode_double_width_0 = Test
467− { test_name = "Verify terminal can display unicode double-width characters. (Direct UTF-8)"
468− , test_ID = "unicode_double_width_0"
469− , test_action = do
470− t <- terminal_handle
471− reserve_display t
472− hide_cursor t
473− withArrayLen (concat utf8_txt_1) (flip $ hPutBuf stdout)
478+utf8Txt1 :: [[Word8]]
479+utf8Txt1 = [ [0xe4,0xbd,0xa0]
480+ , [0xe5,0xa5,0xbd]
481+ , [0xe5,0x90,0x97]
482+ ]
483+
484+iso10646Txt1 :: String
485+iso10646Txt1 = map toEnum [20320,22909,21527]
486+
487+unicodeDoubleWidth0 = Test
488+ { testName = "Verify terminal can display unicode double-width characters. (Direct UTF-8)"
489+ , testID = "unicodeDoubleWidth0"
490+ , testAction = do
491+ t <- standardIOConfig >>= outputForConfig
492+ reserveDisplay t
493+ hideCursor t
494+ withArrayLen (concat utf8Txt1) (flip $ hPutBuf stdout)
474495 hPutStr stdout "\n"
475496 hPutStr stdout "012345\n"
476497 hFlush stdout
477498 getLine
478− release_display t
479− release_terminal t
499+ releaseDisplay t
500+ releaseTerminal t
480501 return ()
481− , print_summary = unicode_double_width_summary
482− , confirm_results = generic_output_match_confirm
502+ , printSummary = unicodeDoubleWidthSummary
503+ , confirmResults = genericOutputMatchConfirm
483504 }
484505
485−unicode_double_width_1 = Test
486− { test_name = "Verify terminal can display unicode double-width characters. (Image ops)"
487− , test_ID = "unicode_double_width_1"
488− , test_action = do
489− t <- terminal_handle
490− reserve_display t
491− let pic = pic_for_image image
492− image = line_0 <-> line_1
493− line_0 = iso_10646_string def_attr iso_10646_txt_1
494− line_1 = string def_attr "012345"
495− d <- display_bounds t >>= display_context t
496− output_picture d pic
506+unicodeDoubleWidth1 = Test
507+ { testName = "Verify terminal can display unicode double-width characters. (Image ops)"
508+ , testID = "unicodeDoubleWidth1"
509+ , testAction = do
510+ t <- standardIOConfig >>= outputForConfig
511+ reserveDisplay t
512+ let pic = picForImage image
513+ image = line0 <-> line1
514+ line0 = iso10646String defAttr iso10646Txt1
515+ line1 = string defAttr "012345"
516+ d <- displayBounds t >>= displayContext t
517+ outputPicture d pic
497518 getLine
498− release_display t
499− release_terminal t
519+ releaseDisplay t
520+ releaseTerminal t
500521 return ()
501− , print_summary = unicode_double_width_summary
502− , confirm_results = generic_output_match_confirm
522+ , printSummary = unicodeDoubleWidthSummary
523+ , confirmResults = genericOutputMatchConfirm
503524 }
504525
505−unicode_double_width_summary = putStr [$heredoc|
526+unicodeDoubleWidthSummary = putStr [s|
506527Once return is pressed:
507528 0. The screen will be cleared.
508529 1. The cursor will be hidden.
@@ -529,33 +550,33 @@ After return is pressed for the second time:
529550 1. The cursor should be visible.
530551|]
531552
532−all_colors = zip [ black, red, green, yellow, blue, magenta, cyan, white ]
533− [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ]
553+allColors = zip [ black, red, green, yellow, blue, magenta, cyan, white ]
554+ [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ]
534555
535−all_bright_colors
536− = zip [ bright_black, bright_red, bright_green, bright_yellow, bright_blue, bright_magenta, bright_cyan, bright_white ]
556+allBrightColors
557+ = zip [ brightBlack, brightRed, brightGreen, brightYellow, brightBlue, brightMagenta, brightCyan, brightWhite ]
537558 [ "bright black", "bright red", "bright green", "bright yellow", "bright blue", "bright magenta", "bright cyan", "bright white" ]
538559
539−attributes_test_0 = Test
540− { test_name = "Character attributes: foreground colors."
541− , test_ID = "attributes_test_0"
542− , test_action = do
543− t <- terminal_handle
544− reserve_display t
545− let pic = pic_for_image image
546− image = border <|> column_0 <|> border <|> column_1 <|> border
547− column_0 = vert_cat $ map line_with_color all_colors
548− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
549− column_1 = vert_cat $ map (string def_attr . snd) all_colors
550− line_with_color (c, c_name) = string (def_attr `with_fore_color` c) c_name
551− d <- display_bounds t >>= display_context t
552− output_picture d pic
560+attributesTest0 = Test
561+ { testName = "Character attributes: foreground colors."
562+ , testID = "attributesTest0"
563+ , testAction = do
564+ t <- standardIOConfig >>= outputForConfig
565+ reserveDisplay t
566+ let pic = picForImage image
567+ image = border <|> column0 <|> border <|> column1 <|> border
568+ column0 = vertCat $ map lineWithColor allColors
569+ border = vertCat $ replicate (length allColors) $ string defAttr " | "
570+ column1 = vertCat $ map (string defAttr . snd) allColors
571+ lineWithColor (c, cName) = string (defAttr `withForeColor` c) cName
572+ d <- displayBounds t >>= displayContext t
573+ outputPicture d pic
553574 getLine
554− release_display t
555− release_terminal t
575+ releaseDisplay t
576+ releaseTerminal t
556577 return ()
557− , print_summary = do
558− putStr $ [$heredoc|
578+ , printSummary = do
579+ putStr $ [s|
559580Once return is pressed:
560581 0. The screen will be cleared.
561582 1. The cursor will be hidden.
@@ -575,33 +596,33 @@ After return is pressed for the second time:
575596 0. The screen containing the test summary should be restored.
576597 1. The cursor should be visible.
577598|]
578− , confirm_results = do
579− putStr $ [$heredoc|
599+ , confirmResults = do
600+ putStr $ [s|
580601Did the test output match the description?
581602|]
582− default_success_confirm_results
603+ defaultSuccessConfirmResults
583604 }
584605
585−attributes_test_1 = Test
586− { test_name = "Character attributes: background colors."
587− , test_ID = "attributes_test_1"
588− , test_action = do
589− t <- terminal_handle
590− reserve_display t
591− let pic = pic_for_image image
592− image = border <|> column_0 <|> border <|> column_1 <|> border
593− column_0 = vert_cat $ map line_with_color all_colors
594− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
595− column_1 = vert_cat $ map (string def_attr . snd) all_colors
596− line_with_color (c, c_name) = string (def_attr `with_back_color` c) c_name
597− d <- display_bounds t >>= display_context t
598− output_picture d pic
606+attributesTest1 = Test
607+ { testName = "Character attributes: background colors."
608+ , testID = "attributesTest1"
609+ , testAction = do
610+ t <- standardIOConfig >>= outputForConfig
611+ reserveDisplay t
612+ let pic = picForImage image
613+ image = border <|> column0 <|> border <|> column1 <|> border
614+ column0 = vertCat $ map lineWithColor allColors
615+ border = vertCat $ replicate (length allColors) $ string defAttr " | "
616+ column1 = vertCat $ map (string defAttr . snd) allColors
617+ lineWithColor (c, cName) = string (defAttr `withBackColor` c) cName
618+ d <- displayBounds t >>= displayContext t
619+ outputPicture d pic
599620 getLine
600− release_display t
601− release_terminal t
621+ releaseDisplay t
622+ releaseTerminal t
602623 return ()
603− , print_summary = do
604− putStr $ [$heredoc|
624+ , printSummary = do
625+ putStr $ [s|
605626Once return is pressed:
606627 0. The screen will be cleared.
607628 1. The cursor will be hidden.
@@ -630,57 +651,57 @@ After return is pressed for the second time:
630651 0. The screen containing the test summary should be restored.
631652 1. The cursor should be visible.
632653|]
633− , confirm_results = do
634− putStr $ [$heredoc|
654+ , confirmResults = do
655+ putStr $ [s|
635656Did the test output match the description?
636657|]
637− default_success_confirm_results
658+ defaultSuccessConfirmResults
638659 }
639660
640−attributes_test_2 = Test
641− { test_name = "Character attributes: Vivid foreground colors."
642− , test_ID = "attributes_test_2"
643− , test_action = do
644− t <- terminal_handle
645− reserve_display t
646− let pic = pic_for_image image
647− image = horiz_cat [border, column_0, border, column_1, border, column_2, border]
648− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
649− column_0 = vert_cat $ map line_with_color_0 all_colors
650− column_1 = vert_cat $ map line_with_color_1 all_bright_colors
651− column_2 = vert_cat $ map (string def_attr . snd) all_colors
652− line_with_color_0 (c, c_name) = string (def_attr `with_fore_color` c) c_name
653− line_with_color_1 (c, c_name) = string (def_attr `with_fore_color` c) c_name
654− d <- display_bounds t >>= display_context t
655− output_picture d pic
661+attributesTest2 = Test
662+ { testName = "Character attributes: Vivid foreground colors."
663+ , testID = "attributesTest2"
664+ , testAction = do
665+ t <- standardIOConfig >>= outputForConfig
666+ reserveDisplay t
667+ let pic = picForImage image
668+ image = horizCat [border, column0, border, column1, border, column2, border]
669+ border = vertCat $ replicate (length allColors) $ string defAttr " | "
670+ column0 = vertCat $ map lineWithColor0 allColors
671+ column1 = vertCat $ map lineWithColor1 allBrightColors
672+ column2 = vertCat $ map (string defAttr . snd) allColors
673+ lineWithColor0 (c, cName) = string (defAttr `withForeColor` c) cName
674+ lineWithColor1 (c, cName) = string (defAttr `withForeColor` c) cName
675+ d <- displayBounds t >>= displayContext t
676+ outputPicture d pic
656677 getLine
657− release_display t
658− release_terminal t
678+ releaseDisplay t
679+ releaseTerminal t
659680 return ()
660− , print_summary = do
661− putStr $ [$heredoc|
681+ , printSummary = do
682+ putStr $ [s|
662683Once return is pressed:
663684 0. The screen will be cleared.
664685 1. The cursor will be hidden.
665686 2. 9 lines of text in three columns will be drawn:
666687 a. The first column will be a name of a standard color (for an 8 color
667− terminal) rendered with that color as the foreground color.
688+ terminal) rendered with that color as the foreground color.
668689 b. The next column will be also be the name of a standard color rendered
669690 with that color as the foreground color but the shade used should be
670− more vivid than the shade used in the first column.
691+ more vivid than the shade used in the first column.
671692 c. The final column will be the name of a color rendered with the
672693 default attributes.
673694
674695For instance, one line will be the word "magenta" and that word should be
675−rendered in the magenta color.
696+rendered in the magenta color.
676697
677698I'm not actually sure exactly what "vivid" means in this context. For xterm the
678−vivid colors are brighter.
699+vivid colors are brighter.
679700
680−Verify:
701+Verify:
681702 * The first column: The foreground color matches the named color.
682703 * The second column: The foreground color matches the named color but is
683− more vivid than the color used in the first column.
704+ more vivid than the color used in the first column.
684705 * The third column: All text is rendered with the default attributes.
685706 * The vertical bars used in each line to mark the border of a column are
686707 lined up.
@@ -689,58 +710,58 @@ After return is pressed for the second time:
689710 0. The screen containing the test summary should be restored.
690711 1. The cursor should be visible.
691712|]
692− , confirm_results = do
693− putStr $ [$heredoc|
713+ , confirmResults = do
714+ putStr $ [s|
694715Did the test output match the description?
695716|]
696− default_success_confirm_results
717+ defaultSuccessConfirmResults
697718 }
698719
699−attributes_test_3 = Test
700− { test_name = "Character attributes: Vivid background colors."
701− , test_ID = "attributes_test_3"
702− , test_action = do
703− t <- terminal_handle
704− reserve_display t
705− let pic = pic_for_image image
706− image = horiz_cat [border, column_0, border, column_1, border, column_2, border]
707− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
708− column_0 = vert_cat $ map line_with_color_0 all_colors
709− column_1 = vert_cat $ map line_with_color_1 all_bright_colors
710− column_2 = vert_cat $ map (string def_attr . snd) all_colors
711− line_with_color_0 (c, c_name) = string (def_attr `with_back_color` c) c_name
712− line_with_color_1 (c, c_name) = string (def_attr `with_back_color` c) c_name
713− d <- display_bounds t >>= display_context t
714− output_picture d pic
720+attributesTest3 = Test
721+ { testName = "Character attributes: Vivid background colors."
722+ , testID = "attributesTest3"
723+ , testAction = do
724+ t <- standardIOConfig >>= outputForConfig
725+ reserveDisplay t
726+ let pic = picForImage image
727+ image = horizCat [border, column0, border, column1, border, column2, border]
728+ border = vertCat $ replicate (length allColors) $ string defAttr " | "
729+ column0 = vertCat $ map lineWithColor0 allColors
730+ column1 = vertCat $ map lineWithColor1 allBrightColors
731+ column2 = vertCat $ map (string defAttr . snd) allColors
732+ lineWithColor0 (c, cName) = string (defAttr `withBackColor` c) cName
733+ lineWithColor1 (c, cName) = string (defAttr `withBackColor` c) cName
734+ d <- displayBounds t >>= displayContext t
735+ outputPicture d pic
715736 getLine
716− release_display t
717− release_terminal t
737+ releaseDisplay t
738+ releaseTerminal t
718739 return ()
719− , print_summary = do
720− putStr $ [$heredoc|
740+ , printSummary = do
741+ putStr $ [s|
721742Once return is pressed:
722743 0. The screen will be cleared.
723744 1. The cursor will be hidden.
724745 2. 9 lines of text in three columns will be drawn:
725746 a. The first column will contain be a name of a standard color for an 8
726747 color terminal rendered with the default foreground color with a
727− background the named color.
748+ background the named color.
728749 b. The first column will contain be a name of a standard color for an 8
729750 color terminal rendered with the default foreground color with the
730− background a vivid version of the named color.
751+ background a vivid version of the named color.
731752 c. The third column will be the name of a standard color rendered with
732753 the default attributes.
733−
754+
734755For instance, one line will contain be the word "magenta" and the word should
735−be rendered in the default foreground color over a magenta background.
756+be rendered in the default foreground color over a magenta background.
736757
737758I'm not actually sure exactly what "vivid" means in this context. For xterm the
738759vivid colors are brighter.
739760
740−Verify:
761+Verify:
741762 * The first column: The background color matches the named color.
742763 * The second column: The background color matches the named color and is
743− more vivid than the color used in the first column.
764+ more vivid than the color used in the first column.
744765 * The third column column: All text is rendered with the default attributes.
745766 * The vertical bars used in each line to mark the border of a column are
746767 lined up.
@@ -756,51 +777,51 @@ After return is pressed for the second time:
756777 0. The screen containing the test summary should be restored.
757778 1. The cursor should be visible.
758779|]
759− , confirm_results = do
760− putStr $ [$heredoc|
780+ , confirmResults = do
781+ putStr $ [s|
761782Did the test output match the description?
762783|]
763− default_success_confirm_results
784+ defaultSuccessConfirmResults
764785 }
765786
766−attr_combos =
787+attrCombos =
767788 [ ( "default", id )
768− , ( "bold", flip with_style bold )
769− , ( "blink", flip with_style blink )
770− , ( "underline", flip with_style underline )
771− , ( "bold + blink", flip with_style (bold + blink) )
772− , ( "bold + underline", flip with_style (bold + underline) )
773− , ( "underline + blink", flip with_style (underline + blink) )
774− , ( "bold + blink + underline", flip with_style (bold + blink + underline) )
789+ , ( "bold", flip withStyle bold )
790+ , ( "blink", flip withStyle blink )
791+ , ( "underline", flip withStyle underline )
792+ , ( "bold + blink", flip withStyle (bold + blink) )
793+ , ( "bold + underline", flip withStyle (bold + underline) )
794+ , ( "underline + blink", flip withStyle (underline + blink) )
795+ , ( "bold + blink + underline", flip withStyle (bold + blink + underline) )
775796 ]
776797
777−attributes_test_4 = Test
778− { test_name = "Character attributes: Bold; Blink; Underline."
779− , test_ID = "attributes_test_4"
780− , test_action = do
781− t <- terminal_handle
782− reserve_display t
783− let pic = pic_for_image image
784− image = horiz_cat [border, column_0, border, column_1, border]
785− border = vert_cat $ replicate (length attr_combos) $ string def_attr " | "
786− column_0 = vert_cat $ map line_with_attrs attr_combos
787− column_1 = vert_cat $ map (string def_attr . fst) attr_combos
788− line_with_attrs (desc, attr_f) = string (attr_f def_attr) desc
789− d <- display_bounds t >>= display_context t
790− output_picture d pic
798+attributesTest4 = Test
799+ { testName = "Character attributes: Bold; Blink; Underline."
800+ , testID = "attributesTest4"
801+ , testAction = do
802+ t <- standardIOConfig >>= outputForConfig
803+ reserveDisplay t
804+ let pic = picForImage image
805+ image = horizCat [border, column0, border, column1, border]
806+ border = vertCat $ replicate (length attrCombos) $ string defAttr " | "
807+ column0 = vertCat $ map lineWithAttrs attrCombos
808+ column1 = vertCat $ map (string defAttr . fst) attrCombos
809+ lineWithAttrs (desc, attrF) = string (attrF defAttr) desc
810+ d <- displayBounds t >>= displayContext t
811+ outputPicture d pic
791812 getLine
792− release_display t
793− release_terminal t
813+ releaseDisplay t
814+ releaseTerminal t
794815 return ()
795− , print_summary = do
796− putStr $ [$heredoc|
816+ , printSummary = do
817+ putStr $ [s|
797818Once return is pressed:
798819 0. The screen will be cleared.
799820 1. The cursor will be hidden.
800− 2. 8 rows of text in two columns.
821+ 2. 8 rows of text in two columns.
801822 The rows will contain the following text:
802823 default
803− bold
824+ bold
804825 blink
805826 underline
806827 bold + blink
@@ -809,8 +830,8 @@ Once return is pressed:
809830 bold + blink + underline
810831 The first column will be rendered with the described attributes. The second
811832 column will be rendered with the default attributes.
812−
813−Verify:
833+
834+Verify:
814835 * The vertical bars used in each line to mark the border of a column are
815836 lined up.
816837 * The text in the first column is rendered as described.
@@ -819,104 +840,353 @@ After return is pressed for the second time:
819840 0. The screen containing the test summary should be restored.
820841 1. The cursor should be visible.
821842|]
822− , confirm_results = do
823− putStr $ [$heredoc|
843+ , confirmResults = do
844+ putStr $ [s|
824845Did the test output match the description?
825846|]
826− default_success_confirm_results
847+ defaultSuccessConfirmResults
827848 }
828849
829−attributes_test_5 = Test
830− { test_name = "Character attributes: 240 color palette"
831− , test_ID = "attributes_test_5"
832− , test_action = do
833− t <- terminal_handle
834− reserve_display t
835− let pic = pic_for_image image
836− image = vert_cat $ map horiz_cat $ split_color_images color_images
837− color_images = map (\i -> string (current_attr `with_back_color` Color240 i) " ") [0..239]
838− split_color_images [] = []
839− split_color_images is = (take 20 is ++ [string def_attr " "]) : (split_color_images (drop 20 is))
840− d <- display_bounds t >>= display_context t
841− output_picture d pic
850+attributesTest5 = Test
851+ { testName = "Character attributes: 240 color palette"
852+ , testID = "attributesTest5"
853+ , testAction = do
854+ t <- standardIOConfig >>= outputForConfig
855+ reserveDisplay t
856+ let pic = picForImage image
857+ image = vertCat $ map horizCat $ splitColorImages colorImages
858+ colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]
859+ splitColorImages [] = []
860+ splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))
861+ d <- displayBounds t >>= displayContext t
862+ outputPicture d pic
842863 getLine
843− release_display t
844− release_terminal t
864+ releaseDisplay t
865+ releaseTerminal t
845866 return ()
846− , print_summary = do
847− putStr $ [$heredoc|
867+ , printSummary = do
868+ putStr $ [s|
848869Once return is pressed:
849870 0. The screen will be cleared.
850871 1. The cursor will be hidden.
851872 2. A 20 character wide and 12 row high block of color squares. This should look like a palette
852873 of some sort. I'm not exactly sure if all color terminals use the same palette. I doubt it...
853874
854−Verify:
875+Verify:
855876
856877After return is pressed for the second time:
857878 0. The screen containing the test summary should be restored.
858879 1. The cursor should be visible.
859880|]
860− , confirm_results = do
861− putStr $ [$heredoc|
881+ , confirmResults = do
882+ putStr $ [s|
862883Did the test output match the description?
863884|]
864− default_success_confirm_results
885+ defaultSuccessConfirmResults
865886 }
866887
867−inline_test_0 = Test
868− { test_name = "Verify styled output can be performed without clearing the screen."
869− , test_ID = "inline_test_0"
870− , test_action = do
871− t <- terminal_handle
888+inlineTest0 = Test
889+ { testName = "Verify styled output can be performed without clearing the screen."
890+ , testID = "inlineTest0"
891+ , testAction = do
872892 putStrLn "line 1."
873− put_attr_change t $ back_color red >> apply_style underline
893+ putAttrChange_ $ backColor red >> applyStyle underline
874894 putStrLn "line 2."
875− put_attr_change t $ default_all
895+ putAttrChange_ $ defaultAll
876896 putStrLn "line 3."
877− release_terminal t
878− return ()
879− , print_summary = putStr $ [$heredoc|
897+ , printSummary = putStr $ [s|
880898lines are in order.
881899The second line "line 2" should have a red background and the text underline.
882900The third line "line 3" should be drawn in the same style as the first line.
883901|]
884902
885− , confirm_results = generic_output_match_confirm
903+ , confirmResults = genericOutputMatchConfirm
886904 }
887905
888−inline_test_1 = Test
889− { test_name = "Verify styled output can be performed without clearing the screen."
890− , test_ID = "inline_test_1"
891− , test_action = do
892− t <- terminal_handle
906+inlineTest1 = Test
907+ { testName = "Verify styled output can be performed without clearing the screen."
908+ , testID = "inlineTest1"
909+ , testAction = do
893910 putStr "Not styled. "
894− put_attr_change t $ back_color red >> apply_style underline
911+ putAttrChange_ $ backColor red >> applyStyle underline
895912 putStr " Styled! "
896− put_attr_change t $ default_all
913+ putAttrChange_ $ defaultAll
897914 putStrLn "Not styled."
898− release_terminal t
899− return ()
900− , print_summary = putStr $ [$heredoc|
915+ , printSummary = putStr $ [s|
901916|]
902917
903− , confirm_results = generic_output_match_confirm
918+ , confirmResults = genericOutputMatchConfirm
919+ }
920+
921+inlineTest2 = Test
922+ { testName = "Verify styled output can be performed without clearing the screen."
923+ , testID = "inlineTest1"
924+ , testAction = do
925+ putStr "Not styled. "
926+ putAttrChange_ $ backColor red >> applyStyle underline
927+ putStr " Styled! "
928+ putAttrChange_ $ defaultAll
929+ putStr "Not styled.\n"
930+ , printSummary = putStr $ [s|
931+|]
932+ , confirmResults = genericOutputMatchConfirm
904933 }
905934
906−inline_test_2 = Test
907− { test_name = "Verify styled output can be performed without clearing the screen."
908− , test_ID = "inline_test_1"
909− , test_action = do
910− t <- terminal_handle
911− put_string t "Not styled. "
912− put_attr_change t $ back_color red >> apply_style underline
913− put_string t " Styled! "
914− put_attr_change t $ default_all
915− put_string t "Not styled.\n"
916− release_terminal t
935+cursorHideTest0 :: Test
936+cursorHideTest0 = Test
937+ { testName = "Verify the cursor is hid and re-shown. issue #7"
938+ , testID = "cursorHideTest0"
939+ , testAction = do
940+ vty <- mkVty defaultConfig
941+ showCursor $ outputIface vty
942+ setCursorPos (outputIface vty) 5 5
943+ nextEvent vty
944+ hideCursor $ outputIface vty
945+ nextEvent vty
946+ shutdown vty
917947 return ()
918− , print_summary = putStr $ [$heredoc|
948+ , printSummary = putStr $ [s|
949+ 1. verify the cursor is displayed.
950+ 2. press enter
951+ 3. verify the cursor is hid.
952+ 4. press enter.
953+ 5. the display should return to the state before the test.
954+|]
955+ , confirmResults = genericOutputMatchConfirm
956+ }
957+
958+outputImageAndWait :: Image -> IO ()
959+outputImageAndWait image = do
960+ let pic = picForImage image
961+ outputPicAndWait pic
962+
963+outputPicAndWait :: Picture -> IO ()
964+outputPicAndWait pic = do
965+ t <- standardIOConfig >>= outputForConfig
966+ reserveDisplay t
967+ d <- displayBounds t >>= displayContext t
968+ outputPicture d pic
969+ getLine
970+ releaseDisplay t
971+ releaseTerminal t
972+ return ()
973+
974+vertCropTest0 :: Test
975+vertCropTest0 = Test
976+ { testName = "Verify bottom cropping works as expected with single column chars"
977+ , testID = "cropTest0"
978+ , testAction = do
979+ let block0 = cropBottom 2 $ vertCat $ map (string defAttr) lorumIpsum
980+ block1 = vertCat $ map (string defAttr) $ take 2 lorumIpsum
981+ image = block0 <-> backgroundFill 10 2 <-> block1
982+ outputImageAndWait image
983+ , printSummary = putStr $ [s|
984+ 1. Verify the two text blocks are identical.
985+ 2. press enter.
986+ 3. the display should return to the state before the test.
987+|]
988+ , confirmResults = genericOutputMatchConfirm
989+ }
990+
991+vertCropTest1 :: Test
992+vertCropTest1 = Test
993+ { testName = "Verify bottom cropping works as expected with double column chars"
994+ , testID = "cropTest0"
995+ , testAction = do
996+ let block0 = cropBottom 2 $ vertCat $ map (string defAttr) lorumIpsumChinese
997+ block1 = vertCat $ map (string defAttr) $ take 2 lorumIpsumChinese
998+ image = block0 <-> backgroundFill 10 2 <-> block1
999+ outputImageAndWait image
1000+ , printSummary = putStr $ [s|
1001+ 1. Verify the two text blocks are identical.
1002+ 2. press enter.
1003+ 3. the display should return to the state before the test.
9191004|]
1005+ , confirmResults = genericOutputMatchConfirm
1006+ }
1007+
1008+vertCropTest2 :: Test
1009+vertCropTest2 = Test
1010+ { testName = "Verify top cropping works as expected with single column chars"
1011+ , testID = "cropTest2"
1012+ , testAction = do
1013+ let block0 = cropTop 2 $ vertCat $ map (string defAttr) lorumIpsum
1014+ block1 = vertCat $ map (string defAttr) $ drop (length lorumIpsum - 2) lorumIpsum
1015+ image = block0 <-> backgroundFill 10 2 <-> block1
1016+ outputImageAndWait image
1017+ , printSummary = putStr $ [s|
1018+ 1. Verify the two text blocks are identical.
1019+ 2. press enter.
1020+ 3. the display should return to the state before the test.
1021+|]
1022+ , confirmResults = genericOutputMatchConfirm
1023+ }
1024+
1025+vertCropTest3 :: Test
1026+vertCropTest3 = Test
1027+ { testName = "Verify top cropping works as expected with double column chars"
1028+ , testID = "cropTest0"
1029+ , testAction = do
1030+ let block0 = cropTop 2 $ vertCat $ map (string defAttr) lorumIpsumChinese
1031+ block1 = vertCat $ map (string defAttr) $ drop (length lorumIpsumChinese - 2 ) lorumIpsumChinese
1032+ image = block0 <-> backgroundFill 10 2 <-> block1
1033+ outputImageAndWait image
1034+ , printSummary = putStr $ [s|
1035+ 1. Verify the two text blocks are identical.
1036+ 2. press enter.
1037+ 3. the display should return to the state before the test.
1038+|]
1039+ , confirmResults = genericOutputMatchConfirm
1040+ }
1041+
1042+horizCropTest0 :: Test
1043+horizCropTest0 = Test
1044+ { testName = "Verify right cropping works as expected with single column chars"
1045+ , testID = "cropTest0"
1046+ , testAction = do
1047+ let baseImage = vertCat $ map (string defAttr) lorumIpsum
1048+ croppedImage = cropRight (imageWidth baseImage `div` 2) baseImage
1049+ image = baseImage <-> backgroundFill 10 2 <-> croppedImage
1050+ outputImageAndWait image
1051+ , printSummary = putStr $ [s|
1052+ 1. Verify the bottom text block is about half the width of the top text block.
1053+ 2. press enter.
1054+ 3. the display should return to the state before the test.
1055+|]
1056+ , confirmResults = genericOutputMatchConfirm
1057+ }
1058+
1059+horizCropTest1 :: Test
1060+horizCropTest1 = Test
1061+ { testName = "Verify right cropping works as expected with double column chars"
1062+ , testID = "cropTest0"
1063+ , testAction = do
1064+ let baseImage = vertCat $ map (string defAttr) lorumIpsumChinese
1065+ croppedImage = cropRight (imageWidth baseImage `div` 2) baseImage
1066+ image = baseImage <-> backgroundFill 10 2 <-> croppedImage
1067+ outputImageAndWait image
1068+ , printSummary = putStr $ [s|
1069+ 1. Verify the bottom text block is the left half of the top block. Ellipses on the right edge are OK.
1070+ 2. press enter.
1071+ 3. the display should return to the state before the test.
1072+|]
1073+ , confirmResults = genericOutputMatchConfirm
1074+ }
1075+
1076+horizCropTest2 :: Test
1077+horizCropTest2 = Test
1078+ { testName = "Verify left cropping works as expected with single column chars"
1079+ , testID = "cropTest0"
1080+ , testAction = do
1081+ let baseImage = vertCat $ map (string defAttr) lorumIpsum
1082+ croppedImage = cropLeft (imageWidth baseImage `div` 2) baseImage
1083+ image = baseImage <-> backgroundFill 10 2 <-> croppedImage
1084+ outputImageAndWait image
1085+ , printSummary = putStr $ [s|
1086+ 1. Verify the bottom text block is the right half of the top text block.
1087+ 2. press enter.
1088+ 3. the display should return to the state before the test.
1089+|]
1090+ , confirmResults = genericOutputMatchConfirm
1091+ }
1092+
1093+horizCropTest3 :: Test
1094+horizCropTest3 = Test
1095+ { testName = "Verify right cropping works as expected with double column chars"
1096+ , testID = "cropTest0"
1097+ , testAction = do
1098+ let baseImage = vertCat $ map (string defAttr) lorumIpsumChinese
1099+ croppedImage = cropLeft (imageWidth baseImage `div` 2) baseImage
1100+ image = baseImage <-> backgroundFill 10 2 <-> croppedImage
1101+ outputImageAndWait image
1102+ , printSummary = putStr $ [s|
1103+ 1. Verify the bottom text block is the right half of the top block. Ellipses on the left edge are OK.
1104+ 2. press enter.
1105+ 3. the display should return to the state before the test.
1106+|]
1107+ , confirmResults = genericOutputMatchConfirm
1108+ }
1109+
1110+layer0 :: Test
1111+layer0 = Test
1112+ { testName = "verify layer 0"
1113+ , testID = "layer0"
1114+ , testAction = do
1115+ let upperImage = vertCat $ map (string defAttr) lorumIpsumChinese
1116+ lowerImage = vertCat $ map (string defAttr) lorumIpsum
1117+ p = picForLayers [upperImage, lowerImage]
1118+ outputPicAndWait p
1119+ , printSummary = putStr $ [s|
1120+ 1. Verify the text block appears to be Chinese text placed on top Latin text.
1121+ 2. press enter.
1122+ 3. the display should return to the state before the test.
1123+|]
1124+ , confirmResults = genericOutputMatchConfirm
1125+ }
9201126
921− , confirm_results = generic_output_match_confirm
1127+layer1 :: Test
1128+layer1 = Test
1129+ { testName = "verify layer 1"
1130+ , testID = "layer1"
1131+ , testAction = do
1132+ let upperImage = vertCat $ map (string defAttr) lorumIpsumChinese
1133+ block = resize 10 10 upperImage
1134+ layer0 = vertCat $ map (string defAttr) lorumIpsum
1135+ layer1 = charFill (defAttr `withBackColor` blue) '#' 1000 1000
1136+ cheesyAnim0 block [layer0, layer1]
1137+ , printSummary = putStr $ [s|
1138+ 1. Verify the text block appears to be Chinese text moving on top a Latin text.
1139+ Which is all on a background of '#' characters over blue.
1140+ 2. press enter.
1141+ 3. the display should return to the state before the test.
1142+|]
1143+ , confirmResults = genericOutputMatchConfirm
9221144 }
1145+
1146+cheesyAnim0 :: Image -> [Image] -> IO ()
1147+cheesyAnim0 i background = do
1148+ t <- standardIOConfig >>= outputForConfig
1149+ reserveDisplay t
1150+ bounds <- displayBounds t
1151+ d <- displayContext t bounds
1152+ forM_ [0..2] $ \t -> do
1153+ forM_ [0..100] $ \t -> do
1154+ let i_offset = translate (t `mod` fst bounds)
1155+ (t `div` 2 `mod` snd bounds)
1156+ i
1157+ let pic = picForLayers $ i_offset : background
1158+ outputPicture d pic
1159+ threadDelay 50000
1160+ forM_ [0..100] $ \t -> do
1161+ let i_offset = translate (t * (-1) `mod` fst bounds)
1162+ (t * (-1) `div` 2 `mod` snd bounds)
1163+ i
1164+ let pic = picForLayers $ i_offset : background
1165+ outputPicture d pic
1166+ threadDelay 50000
1167+ releaseDisplay t
1168+ releaseTerminal t
1169+ return ()
1170+
1171+lorumIpsum :: [String]
1172+lorumIpsum = lines [s|
1173+Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium,
1174+totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae
1175+dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit,
1176+sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. Neque porro quisquam
1177+est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius
1178+modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima
1179+veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea
1180+commodi consequatur? Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil
1181+molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?
1182+|]
1183+
1184+lorumIpsumChinese :: [String]
1185+lorumIpsumChinese = lines [s|
1186+輐銛 螷蟞覮 裌覅詵 暕 鴅噮 槶 惝掭掝 婸媥媕 耏胠臿, 汫汭沎 忕汌卣 蚡袀 僣 蒮 瀁瀎瀊 渮湸湤 緌翢,
1187+腠腶舝 糲蘥蠩 樏殣氀 蒮 蹢鎒 滍 鸄齴 櫧櫋瀩 鬄鵊鵙 莃荶衒, 毸溠 橀 簎艜薤 莃荶衒 翣聜蒢
1188+斔櫅檷 晛桼桾 拻敁柧 犿玒 膣, 墐 笓粊紒 bacon 鼀齕, 蔝蓶蓨 顊顃餭 姴怤 骱 暕 蹢鎒鎛 藒襓謥 鄻鎟霣
1189+鬎鯪, 鐩闤 硻禂稢 谾踘遳 撱 赲 迡 箷 蛃袚觙 萇雊蜩 壿嫷 鋡 縢羱聬 跐鉠鉣 蔝蓶蓨 匢奾灱 溮煡煟 雥齆犪
1190+蔰 虈觿, 腷腯葹 鍹餳駷 蛚袲褁蜸 皯竻 瀁瀎 蜭蜸覟 梪涫湴 揗斝湁 毼
1191+|]
1192+