@@ -2,40 +2,42 @@
22{-# LANGUAGE ScopedTypeVariables #-}
33module Main where
44
5+import Graphics.Vty
56import Graphics.Vty.Attributes
67import Graphics.Vty.Inline
78import Graphics.Vty.Picture
8−import Graphics.Vty.Terminal
9−import Graphics.Vty.DisplayRegion
9+import Graphics.Vty.Output
1010
11+import Control.Concurrent (threadDelay)
12+import Control.Exception
1113import Control.Monad
1214
1315import Data.List ( lookup )
1416import Data.Maybe ( isJust, fromJust )
1517import Data.Monoid
18+import Data.String.QQ
1619import Data.Word
1720
18−import Foreign.Marshal.Array
19−import HereDoc
21+import Foreign.Marshal.Array
2022
2123import qualified System.Environment as Env
2224
2325import System.IO ( hFlush, hPutStr, hPutBuf, stdout )
2426
2527main = do
26− print_intro
28+ printIntro
2729
28−output_file_path = "test_results.list"
30+outputFilePath = "test_results.list"
2931
30−print_intro = do
31− putStr $ [$heredoc|
32+printIntro = do
33+ putStr $ [s|
3234This is an interactive verification program for the terminal input and output
3335support of the VTY library. This will ask a series of questions about what you
3436see on screen. The goal is to verify that VTY's output and input support
3537performs as expected with your terminal.
3638
3739This program produces a file named
38− |] ++ output_file_path ++ [$heredoc|
40+ |] ++ outputFilePath ++ [s|
3941in the current directory that contains the results for each test assertion. This
4042can be emailed to coreyoconnor@gmail.com and used by the VTY authors to improve
4143support for your terminal. No personal information is contained in the report.
@@ -61,42 +63,43 @@ All the tests assume the following about the terminal display:
6163 a good range of the unicode characters. Each test involving unicode display
6264 describes the expected appearance of each glyph.
6365
64−Thanks for the help! :-D
65−To exit the test early enter "q" anytime at the following menu screen. Even if
66−you exit the test early please email the test_results.list file to
67−coreyoconnor@gmail.com. The results file will still contain information useful
68−to debug terminal support.
69−
70−|]
71− wait_for_return
72− results <- do_test_menu 1
73− env_attributes <- mapM ( \env_name -> catch ( Env.getEnv env_name >>= return . (,) env_name )
74− ( const $ return (env_name, "") )
75− )
76− [ "TERM", "COLORTERM", "LANG", "TERM_PROGRAM", "XTERM_VERSION" ]
77− t <- terminal_handle
78− let results_txt = show env_attributes ++ "\n"
79− ++ terminal_ID t ++ "\n"
80− ++ show results ++ "\n"
81− release_terminal t
82− writeFile output_file_path results_txt
83−
84−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
8588 putStr "\n(press return to continue)"
8689 hFlush stdout
8790 getLine
8891
89−test_menu :: [(String, Test)]
90−test_menu = zip (map show [1..]) all_tests
92+testMenu :: [(String, Test)]
93+testMenu = zip (map show [1..]) allTests
9194
92−do_test_menu :: Int -> IO [(String, Bool)]
93−do_test_menu next_ID
94− | next_ID > length all_tests = do
95− 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"
9699 return []
97100 | otherwise = do
98− display_test_menu
99− putStrLn $ "Press return to start with #" ++ show next_ID ++ "."
101+ displayTestMenu
102+ putStrLn $ "Press return to start with #" ++ show nextID ++ "."
100103 putStrLn "Enter a test number to perform only that test."
101104 putStrLn "q (or control-C) to quit."
102105 putStr "> "
@@ -104,91 +107,102 @@ do_test_menu next_ID
104107 s <- getLine >>= return . filter (/= '\n')
105108 case s of
106109 "q" -> return mempty
107− "" -> do
108− r <- run_test $ show next_ID
109− rs <- do_test_menu ( next_ID + 1 )
110+ "" -> do
111+ r <- runTest $ show nextID
112+ rs <- doTestMenu ( nextID + 1 )
110113 return $ r : rs
111− i | isJust ( lookup i test_menu ) -> do
112− r <- run_test i
113− rs <- do_test_menu ( read i + 1 )
114+ i | isJust ( lookup i testMenu ) -> do
115+ r <- runTest i
116+ rs <- doTestMenu ( read i + 1 )
114117 return $ r : rs
115118 where
116− display_test_menu
117− = mapM_ display_test_menu' test_menu
118− display_test_menu' ( i, t )
119− = putStrLn $ ( if i == show next_ID
120− then "> "
119+ displayTestMenu
120+ = mapM_ displayTestMenu' testMenu
121+ displayTestMenu' ( i, t )
122+ = putStrLn $ ( if i == show nextID
123+ then "> "
121124 else " "
122− ) ++ i ++ ". " ++ test_name t
123−
124−run_test :: String -> IO (String, Bool)
125−run_test i = do
126− let t = fromJust $ lookup i test_menu
127− print_summary t
128− wait_for_return
129− test_action t
130− r <- confirm_results t
131− return (test_ID t, r)
132−
133−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
134137 putStr "\n"
135138 putStr "[Y/n] "
136139 hFlush stdout
137140 r <- getLine
138141 case r of
139− "" -> return True
142+ "" -> return True
140143 "y" -> return True
141144 "Y" -> return True
142145 "n" -> return False
143146
144147data Test = Test
145− { test_name :: String
146− , test_ID :: String
147− , test_action :: IO ()
148− , print_summary :: IO ()
149− , confirm_results :: IO Bool
148+ { testName :: String
149+ , testID :: String
150+ , testAction :: IO ()
151+ , printSummary :: IO ()
152+ , confirmResults :: IO Bool
150153 }
151154
152−all_tests
153− = [ reserve_output_test
154− , display_bounds_test_0
155− , display_bounds_test_1
156− , display_bounds_test_2
157− , display_bounds_test_3
158− , unicode_single_width_0
159− , unicode_single_width_1
160− , unicode_double_width_0
161− , unicode_double_width_1
162− , attributes_test_0
163− , attributes_test_1
164− , attributes_test_2
165− , attributes_test_3
166− , attributes_test_4
167− , attributes_test_5
168− , inline_test_0
169− , inline_test_1
170− , 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
171185 ]
172186
173−reserve_output_test = Test
174− { test_name = "Initialize and reserve terminal output then restore previous state."
175− , test_ID = "reserve_output_test"
176− , test_action = do
177− t <- terminal_handle
178− 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
179193 putStrLn "Line 1"
180194 putStrLn "Line 2"
181195 putStrLn "Line 3"
182196 putStrLn "Line 4 (press return)"
183197 hFlush stdout
184198 getLine
185− release_display t
186− release_terminal t
199+ releaseDisplay t
200+ releaseTerminal t
187201 return ()
188− , print_summary = do
189− putStr $ [$heredoc|
202+ , printSummary = do
203+ putStr $ [s|
190204Once return is pressed:
191− 0. The screen will be cleared.
205+ 0. The screen will be cleared.
192206 1. Four lines of text should be visible.
193207 1. The cursor should be visible and at the start of the fifth line.
194208
@@ -196,139 +210,143 @@ After return is pressed for the second time this test then:
196210 * The screen containing the test summary should be restored;
197211 * The cursor is visible.
198212|]
199− , confirm_results = do
200− putStr $ [$heredoc|
213+ , confirmResults = do
214+ putStr $ [s|
201215Did the test output match the description?
202216|]
203− default_success_confirm_results
217+ defaultSuccessConfirmResults
204218 }
205219
206−display_bounds_test_0 = Test
207− { test_name = "Verify display bounds are correct test 0: Using spaces."
208− , test_ID = "display_bounds_test_0"
209− , test_action = do
210− t <- terminal_handle
211− reserve_display t
212− DisplayRegion w h <- display_bounds t
213− let row_0 = replicate (fromEnum w) 'X' ++ "\n"
214− row_h = replicate (fromEnum w - 1) 'X'
215− row_n = "X" ++ replicate (fromEnum w - 2) ' ' ++ "X\n"
216− 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
217231 putStr image
218232 hFlush stdout
219233 getLine
220− release_display t
221− release_terminal t
234+ releaseDisplay t
235+ releaseTerminal t
222236 return ()
223− , print_summary = display_bounds_test_summary True
224− , confirm_results = generic_output_match_confirm
237+ , printSummary = displayBoundsTestSummary True
238+ , confirmResults = genericOutputMatchConfirm
225239 }
226240
227−display_bounds_test_1 = Test
228− { test_name = "Verify display bounds are correct test 0: Using cursor movement."
229− , test_ID = "display_bounds_test_1"
230− , test_action = do
231− t <- terminal_handle
232− reserve_display t
233− DisplayRegion w h <- display_bounds t
234− set_cursor_pos t 0 0
235− let row_0 = replicate (fromEnum w) 'X' ++ "\n"
236− 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
237251 forM_ [1 .. h - 2] $ \y -> do
238− set_cursor_pos t 0 y
252+ setCursorPos t 0 y
239253 putStr "X"
240254 hFlush stdout
241− set_cursor_pos t (w - 1) y
255+ setCursorPos t (w - 1) y
242256 putStr "X"
243257 hFlush stdout
244− set_cursor_pos t 0 (h - 1)
245− let row_h = replicate (fromEnum w - 1) 'X'
246− putStr row_h
258+ setCursorPos t 0 (h - 1)
259+ let rowH = replicate (fromEnum w - 1) 'X'
260+ putStr rowH
247261 hFlush stdout
248262 getLine
249− release_display t
250− release_terminal t
263+ releaseDisplay t
264+ releaseTerminal t
251265 return ()
252− , print_summary = display_bounds_test_summary True
253− , confirm_results = generic_output_match_confirm
266+ , printSummary = displayBoundsTestSummary True
267+ , confirmResults = genericOutputMatchConfirm
254268 }
255269
256−display_bounds_test_2 = Test
257− { test_name = "Verify display bounds are correct test 0: Using Image ops."
258− , test_ID = "display_bounds_test_2"
259− , test_action = do
260− t <- terminal_handle
261− reserve_display t
262− bounds@(DisplayRegion w h) <- display_bounds t
263− let first_row = horiz_cat $ replicate (fromEnum w) (char def_attr 'X')
264− middle_rows = vert_cat $ replicate (fromEnum h - 2) middle_row
265− middle_row = (char def_attr 'X') <|> background_fill (w - 2) 1 <|> (char def_attr 'X')
266− end_row = first_row
267− image = first_row <-> middle_rows <-> end_row
268− pic = (pic_for_image image) { pic_cursor = Cursor (w - 1) (h - 1) }
269− d <- display_context t bounds
270− 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
271285 getLine
272− release_display t
273− release_terminal t
286+ releaseDisplay t
287+ releaseTerminal t
274288 return ()
275− , print_summary = display_bounds_test_summary True
276− , confirm_results = generic_output_match_confirm
289+ , printSummary = displayBoundsTestSummary True
290+ , confirmResults = genericOutputMatchConfirm
277291 }
278292
279−display_bounds_test_3 = Test
280− { test_name = "Verify display bounds are correct test 0: Hide cursor; Set cursor pos."
281− , test_ID = "display_bounds_test_3"
282− , test_action = do
283− t <- terminal_handle
284− reserve_display t
285− DisplayRegion w h <- display_bounds t
286− hide_cursor t
287− set_cursor_pos t 0 0
288− let row_0 = replicate (fromEnum w) 'X'
289− 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
290304 forM_ [1 .. h - 2] $ \y -> do
291− set_cursor_pos t 0 y
305+ setCursorPos t 0 y
292306 putStr "X"
293307 hFlush stdout
294− set_cursor_pos t (w - 1) y
308+ setCursorPos t (w - 1) y
295309 putStr "X"
296310 hFlush stdout
297− set_cursor_pos t 0 (h - 1)
298− let row_h = row_0
299− putStr row_h
311+ setCursorPos t 0 (h - 1)
312+ let rowH = row0
313+ putStr rowH
300314 hFlush stdout
301315 getLine
302− show_cursor t
303− release_display t
304− release_terminal t
316+ showCursor t
317+ releaseDisplay t
318+ releaseTerminal t
305319 return ()
306− , print_summary = display_bounds_test_summary False
307− , confirm_results = generic_output_match_confirm
320+ , printSummary = displayBoundsTestSummary False
321+ , confirmResults = genericOutputMatchConfirm
308322 }
309323
310−display_bounds_test_summary has_cursor = do
311− putStr $ [$heredoc|
324+displayBoundsTestSummary hasCursor = do
325+ putStr $ [s|
312326Once return is pressed:
313327 0. The screen will be cleared.
314328|]
315− if has_cursor
329+ if hasCursor
316330 then putStr " 1. The cursor will be visible."
317331 else putStr " 1. The cursor will NOT be visible."
318− putStr [$heredoc|
332+ putStr [s|
333+
319334 2. The border of the display will be outlined in Xs.
320335 So if - and | represented the edge of the terminal window:
321336 |-------------|
322337 |XXXXXXXXXXXXX|
323338 |X X||]
324339
325− if has_cursor
326− then putStr $ [$heredoc|
340+ if hasCursor
341+ then putStr $ [s|
342+
327343 |XXXXXXXXXXXXC| |]
328− else putStr $ [$heredoc|
344+ else putStr $ [s|
345+
329346 |XXXXXXXXXXXXX| |]
330347
331− putStr $ [$heredoc|
348+ putStr $ [s|
349+
332350 |-------------|
333351
334352 ( Where C is the final position of the cursor. There may be an X drawn
@@ -340,13 +358,13 @@ After return is pressed for the second time:
340358 1. The cursor should be visible.
341359|]
342360
343−generic_output_match_confirm = do
344− putStr $ [$heredoc|
361+genericOutputMatchConfirm = do
362+ putStr $ [s|
345363Did the test output match the description?
346364|]
347− default_success_confirm_results
365+ defaultSuccessConfirmResults
348366
349−-- Explicitely definethe bytes that encode each example text.
367+-- Explicitly define the bytes that encode each example text.
350368-- This avoids any issues with how the compiler represents string literals.
351369--
352370-- This document is UTF-8 encoded so the UTF-8 string is still included for
@@ -355,24 +373,24 @@ Did the test output match the description?
355373-- It's assumed the compiler will at least not barf on UTF-8 encoded text in
356374-- comments ;-)
357375--
358−-- txt_0 = ↑↑↓↓←→←→BA
359−
360−utf8_txt_0 :: [[Word8]]
361−utf8_txt_0 = [ [ 0xe2 , 0x86 , 0x91 ]
362− , [ 0xe2 , 0x86 , 0x91 ]
363− , [ 0xe2 , 0x86 , 0x93 ]
364− , [ 0xe2 , 0x86 , 0x93 ]
365− , [ 0xe2 , 0x86 , 0x90 ]
366− , [ 0xe2 , 0x86 , 0x92 ]
367− , [ 0xe2 , 0x86 , 0x90 ]
368− , [ 0xe2 , 0x86 , 0x92 ]
369− , [ 0x42 ]
370− , [ 0x41 ]
371− ]
372−
373−iso_10646_txt_0 :: String
374−iso_10646_txt_0 = map toEnum
375− [ 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
376394 , 8593
377395 , 8595
378396 , 8595
@@ -384,46 +402,46 @@ iso_10646_txt_0 = map toEnum
384402 , 65
385403 ]
386404
387−unicode_single_width_0 = Test
388− { test_name = "Verify terminal can display unicode single-width characters. (Direct UTF-8)"
389− , test_ID = "unicode_single_width_0"
390− , test_action = do
391− t <- terminal_handle
392− reserve_display t
393− hide_cursor t
394− 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)
395413 hPutStr stdout "\n"
396414 hPutStr stdout "0123456789\n"
397415 hFlush stdout
398416 getLine
399− release_display t
400− release_terminal t
417+ releaseDisplay t
418+ releaseTerminal t
401419 return ()
402− , print_summary = unicode_single_width_summary
403− , confirm_results = generic_output_match_confirm
420+ , printSummary = unicodeSingleWidthSummary
421+ , confirmResults = genericOutputMatchConfirm
404422 }
405423
406−unicode_single_width_1 = Test
407− { test_name = "Verify terminal can display unicode single-width characters. (Image ops)"
408− , test_ID = "unicode_single_width_1"
409− , test_action = do
410− t <- terminal_handle
411− reserve_display t
412− let pic = pic_for_image image
413− image = line_0 <-> line_1
414− line_0 = iso_10646_string def_attr iso_10646_txt_0
415− line_1 = string def_attr "0123456789"
416− d <- display_bounds t >>= display_context t
417− 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
418436 getLine
419− release_display t
420− release_terminal t
437+ releaseDisplay t
438+ releaseTerminal t
421439 return ()
422− , print_summary = unicode_single_width_summary
423− , confirm_results = generic_output_match_confirm
440+ , printSummary = unicodeSingleWidthSummary
441+ , confirmResults = genericOutputMatchConfirm
424442 }
425443
426−unicode_single_width_summary = putStr [$heredoc|
444+unicodeSingleWidthSummary = putStr [s|
427445Once return is pressed:
428446 0. The screen will be cleared.
429447 1. The cursor will be hidden.
@@ -457,55 +475,55 @@ After return is pressed for the second time:
457475
458476-- The second example is a unicode string containing double-width glyphs
459477-- 你好吗
460−utf8_txt_1 :: [[Word8]]
461−utf8_txt_1 = [ [0xe4,0xbd,0xa0]
462− , [0xe5,0xa5,0xbd]
463− , [0xe5,0x90,0x97]
464− ]
465−
466−iso_10646_txt_1 :: String
467−iso_10646_txt_1 = map toEnum [20320,22909,21527]
468−
469−unicode_double_width_0 = Test
470− { test_name = "Verify terminal can display unicode double-width characters. (Direct UTF-8)"
471− , test_ID = "unicode_double_width_0"
472− , test_action = do
473− t <- terminal_handle
474− reserve_display t
475− hide_cursor t
476− 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)
477495 hPutStr stdout "\n"
478496 hPutStr stdout "012345\n"
479497 hFlush stdout
480498 getLine
481− release_display t
482− release_terminal t
499+ releaseDisplay t
500+ releaseTerminal t
483501 return ()
484− , print_summary = unicode_double_width_summary
485− , confirm_results = generic_output_match_confirm
502+ , printSummary = unicodeDoubleWidthSummary
503+ , confirmResults = genericOutputMatchConfirm
486504 }
487505
488−unicode_double_width_1 = Test
489− { test_name = "Verify terminal can display unicode double-width characters. (Image ops)"
490− , test_ID = "unicode_double_width_1"
491− , test_action = do
492− t <- terminal_handle
493− reserve_display t
494− let pic = pic_for_image image
495− image = line_0 <-> line_1
496− line_0 = iso_10646_string def_attr iso_10646_txt_1
497− line_1 = string def_attr "012345"
498− d <- display_bounds t >>= display_context t
499− 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
500518 getLine
501− release_display t
502− release_terminal t
519+ releaseDisplay t
520+ releaseTerminal t
503521 return ()
504− , print_summary = unicode_double_width_summary
505− , confirm_results = generic_output_match_confirm
522+ , printSummary = unicodeDoubleWidthSummary
523+ , confirmResults = genericOutputMatchConfirm
506524 }
507525
508−unicode_double_width_summary = putStr [$heredoc|
526+unicodeDoubleWidthSummary = putStr [s|
509527Once return is pressed:
510528 0. The screen will be cleared.
511529 1. The cursor will be hidden.
@@ -532,33 +550,33 @@ After return is pressed for the second time:
532550 1. The cursor should be visible.
533551|]
534552
535−all_colors = zip [ black, red, green, yellow, blue, magenta, cyan, white ]
536− [ "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" ]
537555
538−all_bright_colors
539− = 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 ]
540558 [ "bright black", "bright red", "bright green", "bright yellow", "bright blue", "bright magenta", "bright cyan", "bright white" ]
541559
542−attributes_test_0 = Test
543− { test_name = "Character attributes: foreground colors."
544− , test_ID = "attributes_test_0"
545− , test_action = do
546− t <- terminal_handle
547− reserve_display t
548− let pic = pic_for_image image
549− image = border <|> column_0 <|> border <|> column_1 <|> border
550− column_0 = vert_cat $ map line_with_color all_colors
551− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
552− column_1 = vert_cat $ map (string def_attr . snd) all_colors
553− line_with_color (c, c_name) = string (def_attr `with_fore_color` c) c_name
554− d <- display_bounds t >>= display_context t
555− 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
556574 getLine
557− release_display t
558− release_terminal t
575+ releaseDisplay t
576+ releaseTerminal t
559577 return ()
560− , print_summary = do
561− putStr $ [$heredoc|
578+ , printSummary = do
579+ putStr $ [s|
562580Once return is pressed:
563581 0. The screen will be cleared.
564582 1. The cursor will be hidden.
@@ -578,33 +596,33 @@ After return is pressed for the second time:
578596 0. The screen containing the test summary should be restored.
579597 1. The cursor should be visible.
580598|]
581− , confirm_results = do
582− putStr $ [$heredoc|
599+ , confirmResults = do
600+ putStr $ [s|
583601Did the test output match the description?
584602|]
585− default_success_confirm_results
603+ defaultSuccessConfirmResults
586604 }
587605
588−attributes_test_1 = Test
589− { test_name = "Character attributes: background colors."
590− , test_ID = "attributes_test_1"
591− , test_action = do
592− t <- terminal_handle
593− reserve_display t
594− let pic = pic_for_image image
595− image = border <|> column_0 <|> border <|> column_1 <|> border
596− column_0 = vert_cat $ map line_with_color all_colors
597− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
598− column_1 = vert_cat $ map (string def_attr . snd) all_colors
599− line_with_color (c, c_name) = string (def_attr `with_back_color` c) c_name
600− d <- display_bounds t >>= display_context t
601− 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
602620 getLine
603− release_display t
604− release_terminal t
621+ releaseDisplay t
622+ releaseTerminal t
605623 return ()
606− , print_summary = do
607− putStr $ [$heredoc|
624+ , printSummary = do
625+ putStr $ [s|
608626Once return is pressed:
609627 0. The screen will be cleared.
610628 1. The cursor will be hidden.
@@ -633,57 +651,57 @@ After return is pressed for the second time:
633651 0. The screen containing the test summary should be restored.
634652 1. The cursor should be visible.
635653|]
636− , confirm_results = do
637− putStr $ [$heredoc|
654+ , confirmResults = do
655+ putStr $ [s|
638656Did the test output match the description?
639657|]
640− default_success_confirm_results
658+ defaultSuccessConfirmResults
641659 }
642660
643−attributes_test_2 = Test
644− { test_name = "Character attributes: Vivid foreground colors."
645− , test_ID = "attributes_test_2"
646− , test_action = do
647− t <- terminal_handle
648− reserve_display t
649− let pic = pic_for_image image
650− image = horiz_cat [border, column_0, border, column_1, border, column_2, border]
651− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
652− column_0 = vert_cat $ map line_with_color_0 all_colors
653− column_1 = vert_cat $ map line_with_color_1 all_bright_colors
654− column_2 = vert_cat $ map (string def_attr . snd) all_colors
655− line_with_color_0 (c, c_name) = string (def_attr `with_fore_color` c) c_name
656− line_with_color_1 (c, c_name) = string (def_attr `with_fore_color` c) c_name
657− d <- display_bounds t >>= display_context t
658− 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
659677 getLine
660− release_display t
661− release_terminal t
678+ releaseDisplay t
679+ releaseTerminal t
662680 return ()
663− , print_summary = do
664− putStr $ [$heredoc|
681+ , printSummary = do
682+ putStr $ [s|
665683Once return is pressed:
666684 0. The screen will be cleared.
667685 1. The cursor will be hidden.
668686 2. 9 lines of text in three columns will be drawn:
669687 a. The first column will be a name of a standard color (for an 8 color
670− terminal) rendered with that color as the foreground color.
688+ terminal) rendered with that color as the foreground color.
671689 b. The next column will be also be the name of a standard color rendered
672690 with that color as the foreground color but the shade used should be
673− more vivid than the shade used in the first column.
691+ more vivid than the shade used in the first column.
674692 c. The final column will be the name of a color rendered with the
675693 default attributes.
676694
677695For instance, one line will be the word "magenta" and that word should be
678−rendered in the magenta color.
696+rendered in the magenta color.
679697
680698I'm not actually sure exactly what "vivid" means in this context. For xterm the
681−vivid colors are brighter.
699+vivid colors are brighter.
682700
683−Verify:
701+Verify:
684702 * The first column: The foreground color matches the named color.
685703 * The second column: The foreground color matches the named color but is
686− more vivid than the color used in the first column.
704+ more vivid than the color used in the first column.
687705 * The third column: All text is rendered with the default attributes.
688706 * The vertical bars used in each line to mark the border of a column are
689707 lined up.
@@ -692,58 +710,58 @@ After return is pressed for the second time:
692710 0. The screen containing the test summary should be restored.
693711 1. The cursor should be visible.
694712|]
695− , confirm_results = do
696− putStr $ [$heredoc|
713+ , confirmResults = do
714+ putStr $ [s|
697715Did the test output match the description?
698716|]
699− default_success_confirm_results
717+ defaultSuccessConfirmResults
700718 }
701719
702−attributes_test_3 = Test
703− { test_name = "Character attributes: Vivid background colors."
704− , test_ID = "attributes_test_3"
705− , test_action = do
706− t <- terminal_handle
707− reserve_display t
708− let pic = pic_for_image image
709− image = horiz_cat [border, column_0, border, column_1, border, column_2, border]
710− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
711− column_0 = vert_cat $ map line_with_color_0 all_colors
712− column_1 = vert_cat $ map line_with_color_1 all_bright_colors
713− column_2 = vert_cat $ map (string def_attr . snd) all_colors
714− line_with_color_0 (c, c_name) = string (def_attr `with_back_color` c) c_name
715− line_with_color_1 (c, c_name) = string (def_attr `with_back_color` c) c_name
716− d <- display_bounds t >>= display_context t
717− 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
718736 getLine
719− release_display t
720− release_terminal t
737+ releaseDisplay t
738+ releaseTerminal t
721739 return ()
722− , print_summary = do
723− putStr $ [$heredoc|
740+ , printSummary = do
741+ putStr $ [s|
724742Once return is pressed:
725743 0. The screen will be cleared.
726744 1. The cursor will be hidden.
727745 2. 9 lines of text in three columns will be drawn:
728746 a. The first column will contain be a name of a standard color for an 8
729747 color terminal rendered with the default foreground color with a
730− background the named color.
748+ background the named color.
731749 b. The first column will contain be a name of a standard color for an 8
732750 color terminal rendered with the default foreground color with the
733− background a vivid version of the named color.
751+ background a vivid version of the named color.
734752 c. The third column will be the name of a standard color rendered with
735753 the default attributes.
736−
754+
737755For instance, one line will contain be the word "magenta" and the word should
738−be rendered in the default foreground color over a magenta background.
756+be rendered in the default foreground color over a magenta background.
739757
740758I'm not actually sure exactly what "vivid" means in this context. For xterm the
741759vivid colors are brighter.
742760
743−Verify:
761+Verify:
744762 * The first column: The background color matches the named color.
745763 * The second column: The background color matches the named color and is
746− more vivid than the color used in the first column.
764+ more vivid than the color used in the first column.
747765 * The third column column: All text is rendered with the default attributes.
748766 * The vertical bars used in each line to mark the border of a column are
749767 lined up.
@@ -759,51 +777,51 @@ After return is pressed for the second time:
759777 0. The screen containing the test summary should be restored.
760778 1. The cursor should be visible.
761779|]
762− , confirm_results = do
763− putStr $ [$heredoc|
780+ , confirmResults = do
781+ putStr $ [s|
764782Did the test output match the description?
765783|]
766− default_success_confirm_results
784+ defaultSuccessConfirmResults
767785 }
768786
769−attr_combos =
787+attrCombos =
770788 [ ( "default", id )
771− , ( "bold", flip with_style bold )
772− , ( "blink", flip with_style blink )
773− , ( "underline", flip with_style underline )
774− , ( "bold + blink", flip with_style (bold + blink) )
775− , ( "bold + underline", flip with_style (bold + underline) )
776− , ( "underline + blink", flip with_style (underline + blink) )
777− , ( "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) )
778796 ]
779797
780−attributes_test_4 = Test
781− { test_name = "Character attributes: Bold; Blink; Underline."
782− , test_ID = "attributes_test_4"
783− , test_action = do
784− t <- terminal_handle
785− reserve_display t
786− let pic = pic_for_image image
787− image = horiz_cat [border, column_0, border, column_1, border]
788− border = vert_cat $ replicate (length attr_combos) $ string def_attr " | "
789− column_0 = vert_cat $ map line_with_attrs attr_combos
790− column_1 = vert_cat $ map (string def_attr . fst) attr_combos
791− line_with_attrs (desc, attr_f) = string (attr_f def_attr) desc
792− d <- display_bounds t >>= display_context t
793− 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
794812 getLine
795− release_display t
796− release_terminal t
813+ releaseDisplay t
814+ releaseTerminal t
797815 return ()
798− , print_summary = do
799− putStr $ [$heredoc|
816+ , printSummary = do
817+ putStr $ [s|
800818Once return is pressed:
801819 0. The screen will be cleared.
802820 1. The cursor will be hidden.
803− 2. 8 rows of text in two columns.
821+ 2. 8 rows of text in two columns.
804822 The rows will contain the following text:
805823 default
806− bold
824+ bold
807825 blink
808826 underline
809827 bold + blink
@@ -812,8 +830,8 @@ Once return is pressed:
812830 bold + blink + underline
813831 The first column will be rendered with the described attributes. The second
814832 column will be rendered with the default attributes.
815−
816−Verify:
833+
834+Verify:
817835 * The vertical bars used in each line to mark the border of a column are
818836 lined up.
819837 * The text in the first column is rendered as described.
@@ -822,105 +840,353 @@ After return is pressed for the second time:
822840 0. The screen containing the test summary should be restored.
823841 1. The cursor should be visible.
824842|]
825− , confirm_results = do
826− putStr $ [$heredoc|
843+ , confirmResults = do
844+ putStr $ [s|
827845Did the test output match the description?
828846|]
829− default_success_confirm_results
847+ defaultSuccessConfirmResults
830848 }
831849
832−attributes_test_5 = Test
833− { test_name = "Character attributes: 240 color palette"
834− , test_ID = "attributes_test_5"
835− , test_action = do
836− t <- terminal_handle
837− reserve_display t
838− let pic = pic_for_image image
839− image = vert_cat $ map horiz_cat $ split_color_images color_images
840− color_images = map (\i -> string (current_attr `with_back_color` Color240 i) " ") [0..239]
841− split_color_images [] = []
842− split_color_images is = (take 20 is ++ [string def_attr " "]) : (split_color_images (drop 20 is))
843− d <- display_bounds t >>= display_context t
844− 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
845863 getLine
846− release_display t
847− release_terminal t
864+ releaseDisplay t
865+ releaseTerminal t
848866 return ()
849− , print_summary = do
850− putStr $ [$heredoc|
867+ , printSummary = do
868+ putStr $ [s|
851869Once return is pressed:
852870 0. The screen will be cleared.
853871 1. The cursor will be hidden.
854872 2. A 20 character wide and 12 row high block of color squares. This should look like a palette
855873 of some sort. I'm not exactly sure if all color terminals use the same palette. I doubt it...
856874
857−Verify:
875+Verify:
858876
859877After return is pressed for the second time:
860878 0. The screen containing the test summary should be restored.
861879 1. The cursor should be visible.
862880|]
863− , confirm_results = do
864− putStr $ [$heredoc|
881+ , confirmResults = do
882+ putStr $ [s|
865883Did the test output match the description?
866884|]
867− default_success_confirm_results
885+ defaultSuccessConfirmResults
868886 }
869887
870−inline_test_0 = Test
871− { test_name = "Verify styled output can be performed without clearing the screen."
872− , test_ID = "inline_test_0"
873− , test_action = do
874− t <- terminal_handle
888+inlineTest0 = Test
889+ { testName = "Verify styled output can be performed without clearing the screen."
890+ , testID = "inlineTest0"
891+ , testAction = do
875892 putStrLn "line 1."
876− put_attr_change t $ back_color red >> apply_style underline
893+ putAttrChange_ $ backColor red >> applyStyle underline
877894 putStrLn "line 2."
878− put_attr_change t $ default_all
895+ putAttrChange_ $ defaultAll
879896 putStrLn "line 3."
880− release_terminal t
881− return ()
882− , print_summary = putStr $ [$heredoc|
897+ , printSummary = putStr $ [s|
883898lines are in order.
884899The second line "line 2" should have a red background and the text underline.
885900The third line "line 3" should be drawn in the same style as the first line.
886901|]
887902
888− , confirm_results = generic_output_match_confirm
903+ , confirmResults = genericOutputMatchConfirm
889904 }
890905
891−inline_test_1 = Test
892− { test_name = "Verify styled output can be performed without clearing the screen."
893− , test_ID = "inline_test_1"
894− , test_action = do
895− t <- terminal_handle
906+inlineTest1 = Test
907+ { testName = "Verify styled output can be performed without clearing the screen."
908+ , testID = "inlineTest1"
909+ , testAction = do
896910 putStr "Not styled. "
897− put_attr_change t $ back_color red >> apply_style underline
911+ putAttrChange_ $ backColor red >> applyStyle underline
898912 putStr " Styled! "
899− put_attr_change t $ default_all
913+ putAttrChange_ $ defaultAll
900914 putStrLn "Not styled."
901− release_terminal t
902− return ()
903− , print_summary = putStr $ [$heredoc|
915+ , printSummary = putStr $ [s|
904916|]
905917
906− , confirm_results = generic_output_match_confirm
918+ , confirmResults = genericOutputMatchConfirm
907919 }
908920
909−inline_test_2 = Test
910− { test_name = "Verify styled output can be performed without clearing the screen."
911− , test_ID = "inline_test_1"
912− , test_action = do
913− t <- terminal_handle
921+inlineTest2 = Test
922+ { testName = "Verify styled output can be performed without clearing the screen."
923+ , testID = "inlineTest1"
924+ , testAction = do
914925 putStr "Not styled. "
915− put_attr_change t $ back_color red >> apply_style underline
926+ putAttrChange_ $ backColor red >> applyStyle underline
916927 putStr " Styled! "
917− put_attr_change t $ default_all
928+ putAttrChange_ $ defaultAll
918929 putStr "Not styled.\n"
919− release_terminal t
930+ , printSummary = putStr $ [s|
931+|]
932+ , confirmResults = genericOutputMatchConfirm
933+ }
934+
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
920947 return ()
921− , 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.
922954|]
955+ , confirmResults = genericOutputMatchConfirm
956+ }
923957
924− , confirm_results = generic_output_match_confirm
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.
1004+|]
1005+ , confirmResults = genericOutputMatchConfirm
9251006 }
9261007
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+ }
1126+
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
1144+ }
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+