@@ -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,90 +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
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,135 +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"
240− set_cursor_pos t (w - 1) y
254+ hFlush stdout
255+ setCursorPos t (w - 1) y
241256 putStr "X"
242− set_cursor_pos t 0 (h - 1)
243− let row_h = replicate (fromEnum w - 1) 'X'
244− putStr row_h
257+ hFlush stdout
258+ setCursorPos t 0 (h - 1)
259+ let rowH = replicate (fromEnum w - 1) 'X'
260+ putStr rowH
245261 hFlush stdout
246262 getLine
247− release_display t
248− release_terminal t
263+ releaseDisplay t
264+ releaseTerminal t
249265 return ()
250− , print_summary = display_bounds_test_summary True
251− , confirm_results = generic_output_match_confirm
266+ , printSummary = displayBoundsTestSummary True
267+ , confirmResults = genericOutputMatchConfirm
252268 }
253269
254−display_bounds_test_2 = Test
255− { test_name = "Verify display bounds are correct test 0: Using Image ops."
256− , test_ID = "display_bounds_test_2"
257− , test_action = do
258− t <- terminal_handle
259− reserve_display t
260− bounds@(DisplayRegion w h) <- display_bounds t
261− let first_row = horiz_cat $ replicate (fromEnum w) (char def_attr 'X')
262− middle_rows = vert_cat $ replicate (fromEnum h - 2) middle_row
263− middle_row = (char def_attr 'X') <|> background_fill (w - 2) 1 <|> (char def_attr 'X')
264− end_row = first_row
265− image = first_row <-> middle_rows <-> end_row
266− pic = (pic_for_image image) { pic_cursor = Cursor (w - 1) (h - 1) }
267− d <- display_context t bounds
268− 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
269285 getLine
270− release_display t
271− release_terminal t
286+ releaseDisplay t
287+ releaseTerminal t
272288 return ()
273− , print_summary = display_bounds_test_summary True
274− , confirm_results = generic_output_match_confirm
289+ , printSummary = displayBoundsTestSummary True
290+ , confirmResults = genericOutputMatchConfirm
275291 }
276292
277−display_bounds_test_3 = Test
278− { test_name = "Verify display bounds are correct test 0: Hide cursor; Set cursor pos."
279− , test_ID = "display_bounds_test_3"
280− , test_action = do
281− t <- terminal_handle
282− reserve_display t
283− DisplayRegion w h <- display_bounds t
284− hide_cursor t
285− set_cursor_pos t 0 0
286− let row_0 = replicate (fromEnum w) 'X'
287− 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
288304 forM_ [1 .. h - 2] $ \y -> do
289− set_cursor_pos t 0 y
305+ setCursorPos t 0 y
290306 putStr "X"
291− set_cursor_pos t (w - 1) y
307+ hFlush stdout
308+ setCursorPos t (w - 1) y
292309 putStr "X"
293− set_cursor_pos t 0 (h - 1)
294− let row_h = row_0
295− putStr row_h
310+ hFlush stdout
311+ setCursorPos t 0 (h - 1)
312+ let rowH = row0
313+ putStr rowH
296314 hFlush stdout
297315 getLine
298− show_cursor t
299− release_display t
300− release_terminal t
316+ showCursor t
317+ releaseDisplay t
318+ releaseTerminal t
301319 return ()
302− , print_summary = display_bounds_test_summary False
303− , confirm_results = generic_output_match_confirm
320+ , printSummary = displayBoundsTestSummary False
321+ , confirmResults = genericOutputMatchConfirm
304322 }
305323
306−display_bounds_test_summary has_cursor = do
307− putStr $ [$heredoc|
324+displayBoundsTestSummary hasCursor = do
325+ putStr $ [s|
308326Once return is pressed:
309327 0. The screen will be cleared.
310328|]
311− if has_cursor
329+ if hasCursor
312330 then putStr " 1. The cursor will be visible."
313331 else putStr " 1. The cursor will NOT be visible."
314− putStr [$heredoc|
332+ putStr [s|
333+
315334 2. The border of the display will be outlined in Xs.
316335 So if - and | represented the edge of the terminal window:
317336 |-------------|
318337 |XXXXXXXXXXXXX|
319338 |X X||]
320339
321− if has_cursor
322− then putStr $ [$heredoc|
340+ if hasCursor
341+ then putStr $ [s|
342+
323343 |XXXXXXXXXXXXC| |]
324− else putStr $ [$heredoc|
344+ else putStr $ [s|
345+
325346 |XXXXXXXXXXXXX| |]
326347
327− putStr $ [$heredoc|
348+ putStr $ [s|
349+
328350 |-------------|
329351
330352 ( Where C is the final position of the cursor. There may be an X drawn
@@ -336,13 +358,13 @@ After return is pressed for the second time:
336358 1. The cursor should be visible.
337359|]
338360
339−generic_output_match_confirm = do
340− putStr $ [$heredoc|
361+genericOutputMatchConfirm = do
362+ putStr $ [s|
341363Did the test output match the description?
342364|]
343− default_success_confirm_results
365+ defaultSuccessConfirmResults
344366
345−-- Explicitely definethe bytes that encode each example text.
367+-- Explicitly define the bytes that encode each example text.
346368-- This avoids any issues with how the compiler represents string literals.
347369--
348370-- This document is UTF-8 encoded so the UTF-8 string is still included for
@@ -351,24 +373,24 @@ Did the test output match the description?
351373-- It's assumed the compiler will at least not barf on UTF-8 encoded text in
352374-- comments ;-)
353375--
354−-- txt_0 = ↑↑↓↓←→←→BA
355−
356−utf8_txt_0 :: [[Word8]]
357−utf8_txt_0 = [ [ 0xe2 , 0x86 , 0x91 ]
358− , [ 0xe2 , 0x86 , 0x91 ]
359− , [ 0xe2 , 0x86 , 0x93 ]
360− , [ 0xe2 , 0x86 , 0x93 ]
361− , [ 0xe2 , 0x86 , 0x90 ]
362− , [ 0xe2 , 0x86 , 0x92 ]
363− , [ 0xe2 , 0x86 , 0x90 ]
364− , [ 0xe2 , 0x86 , 0x92 ]
365− , [ 0x42 ]
366− , [ 0x41 ]
367− ]
368−
369−iso_10646_txt_0 :: String
370−iso_10646_txt_0 = map toEnum
371− [ 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
372394 , 8593
373395 , 8595
374396 , 8595
@@ -380,46 +402,46 @@ iso_10646_txt_0 = map toEnum
380402 , 65
381403 ]
382404
383−unicode_single_width_0 = Test
384− { test_name = "Verify terminal can display unicode single-width characters. (Direct UTF-8)"
385− , test_ID = "unicode_single_width_0"
386− , test_action = do
387− t <- terminal_handle
388− reserve_display t
389− hide_cursor t
390− 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)
391413 hPutStr stdout "\n"
392414 hPutStr stdout "0123456789\n"
393415 hFlush stdout
394416 getLine
395− release_display t
396− release_terminal t
417+ releaseDisplay t
418+ releaseTerminal t
397419 return ()
398− , print_summary = unicode_single_width_summary
399− , confirm_results = generic_output_match_confirm
420+ , printSummary = unicodeSingleWidthSummary
421+ , confirmResults = genericOutputMatchConfirm
400422 }
401423
402−unicode_single_width_1 = Test
403− { test_name = "Verify terminal can display unicode single-width characters. (Image ops)"
404− , test_ID = "unicode_single_width_1"
405− , test_action = do
406− t <- terminal_handle
407− reserve_display t
408− let pic = pic_for_image image
409− image = line_0 <-> line_1
410− line_0 = iso_10646_string def_attr iso_10646_txt_0
411− line_1 = string def_attr "0123456789"
412− d <- display_bounds t >>= display_context t
413− 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
414436 getLine
415− release_display t
416− release_terminal t
437+ releaseDisplay t
438+ releaseTerminal t
417439 return ()
418− , print_summary = unicode_single_width_summary
419− , confirm_results = generic_output_match_confirm
440+ , printSummary = unicodeSingleWidthSummary
441+ , confirmResults = genericOutputMatchConfirm
420442 }
421443
422−unicode_single_width_summary = putStr [$heredoc|
444+unicodeSingleWidthSummary = putStr [s|
423445Once return is pressed:
424446 0. The screen will be cleared.
425447 1. The cursor will be hidden.
@@ -453,55 +475,55 @@ After return is pressed for the second time:
453475
454476-- The second example is a unicode string containing double-width glyphs
455477-- 你好吗
456−utf8_txt_1 :: [[Word8]]
457−utf8_txt_1 = [ [0xe4,0xbd,0xa0]
458− , [0xe5,0xa5,0xbd]
459− , [0xe5,0x90,0x97]
460− ]
461−
462−iso_10646_txt_1 :: String
463−iso_10646_txt_1 = map toEnum [20320,22909,21527]
464−
465−unicode_double_width_0 = Test
466− { test_name = "Verify terminal can display unicode double-width characters. (Direct UTF-8)"
467− , test_ID = "unicode_double_width_0"
468− , test_action = do
469− t <- terminal_handle
470− reserve_display t
471− hide_cursor t
472− 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)
473495 hPutStr stdout "\n"
474496 hPutStr stdout "012345\n"
475497 hFlush stdout
476498 getLine
477− release_display t
478− release_terminal t
499+ releaseDisplay t
500+ releaseTerminal t
479501 return ()
480− , print_summary = unicode_double_width_summary
481− , confirm_results = generic_output_match_confirm
502+ , printSummary = unicodeDoubleWidthSummary
503+ , confirmResults = genericOutputMatchConfirm
482504 }
483505
484−unicode_double_width_1 = Test
485− { test_name = "Verify terminal can display unicode double-width characters. (Image ops)"
486− , test_ID = "unicode_double_width_1"
487− , test_action = do
488− t <- terminal_handle
489− reserve_display t
490− let pic = pic_for_image image
491− image = line_0 <-> line_1
492− line_0 = iso_10646_string def_attr iso_10646_txt_1
493− line_1 = string def_attr "012345"
494− d <- display_bounds t >>= display_context t
495− 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
496518 getLine
497− release_display t
498− release_terminal t
519+ releaseDisplay t
520+ releaseTerminal t
499521 return ()
500− , print_summary = unicode_double_width_summary
501− , confirm_results = generic_output_match_confirm
522+ , printSummary = unicodeDoubleWidthSummary
523+ , confirmResults = genericOutputMatchConfirm
502524 }
503525
504−unicode_double_width_summary = putStr [$heredoc|
526+unicodeDoubleWidthSummary = putStr [s|
505527Once return is pressed:
506528 0. The screen will be cleared.
507529 1. The cursor will be hidden.
@@ -528,33 +550,33 @@ After return is pressed for the second time:
528550 1. The cursor should be visible.
529551|]
530552
531−all_colors = zip [ black, red, green, yellow, blue, magenta, cyan, white ]
532− [ "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" ]
533555
534−all_bright_colors
535− = 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 ]
536558 [ "bright black", "bright red", "bright green", "bright yellow", "bright blue", "bright magenta", "bright cyan", "bright white" ]
537559
538−attributes_test_0 = Test
539− { test_name = "Character attributes: foreground colors."
540− , test_ID = "attributes_test_0"
541− , test_action = do
542− t <- terminal_handle
543− reserve_display t
544− let pic = pic_for_image image
545− image = border <|> column_0 <|> border <|> column_1 <|> border
546− column_0 = vert_cat $ map line_with_color all_colors
547− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
548− column_1 = vert_cat $ map (string def_attr . snd) all_colors
549− line_with_color (c, c_name) = string (def_attr `with_fore_color` c) c_name
550− d <- display_bounds t >>= display_context t
551− 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
552574 getLine
553− release_display t
554− release_terminal t
575+ releaseDisplay t
576+ releaseTerminal t
555577 return ()
556− , print_summary = do
557− putStr $ [$heredoc|
578+ , printSummary = do
579+ putStr $ [s|
558580Once return is pressed:
559581 0. The screen will be cleared.
560582 1. The cursor will be hidden.
@@ -574,33 +596,33 @@ After return is pressed for the second time:
574596 0. The screen containing the test summary should be restored.
575597 1. The cursor should be visible.
576598|]
577− , confirm_results = do
578− putStr $ [$heredoc|
599+ , confirmResults = do
600+ putStr $ [s|
579601Did the test output match the description?
580602|]
581− default_success_confirm_results
603+ defaultSuccessConfirmResults
582604 }
583605
584−attributes_test_1 = Test
585− { test_name = "Character attributes: background colors."
586− , test_ID = "attributes_test_1"
587− , test_action = do
588− t <- terminal_handle
589− reserve_display t
590− let pic = pic_for_image image
591− image = border <|> column_0 <|> border <|> column_1 <|> border
592− column_0 = vert_cat $ map line_with_color all_colors
593− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
594− column_1 = vert_cat $ map (string def_attr . snd) all_colors
595− line_with_color (c, c_name) = string (def_attr `with_back_color` c) c_name
596− d <- display_bounds t >>= display_context t
597− 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
598620 getLine
599− release_display t
600− release_terminal t
621+ releaseDisplay t
622+ releaseTerminal t
601623 return ()
602− , print_summary = do
603− putStr $ [$heredoc|
624+ , printSummary = do
625+ putStr $ [s|
604626Once return is pressed:
605627 0. The screen will be cleared.
606628 1. The cursor will be hidden.
@@ -629,57 +651,57 @@ After return is pressed for the second time:
629651 0. The screen containing the test summary should be restored.
630652 1. The cursor should be visible.
631653|]
632− , confirm_results = do
633− putStr $ [$heredoc|
654+ , confirmResults = do
655+ putStr $ [s|
634656Did the test output match the description?
635657|]
636− default_success_confirm_results
658+ defaultSuccessConfirmResults
637659 }
638660
639−attributes_test_2 = Test
640− { test_name = "Character attributes: Vivid foreground colors."
641− , test_ID = "attributes_test_2"
642− , test_action = do
643− t <- terminal_handle
644− reserve_display t
645− let pic = pic_for_image image
646− image = horiz_cat [border, column_0, border, column_1, border, column_2, border]
647− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
648− column_0 = vert_cat $ map line_with_color_0 all_colors
649− column_1 = vert_cat $ map line_with_color_1 all_bright_colors
650− column_2 = vert_cat $ map (string def_attr . snd) all_colors
651− line_with_color_0 (c, c_name) = string (def_attr `with_fore_color` c) c_name
652− line_with_color_1 (c, c_name) = string (def_attr `with_fore_color` c) c_name
653− d <- display_bounds t >>= display_context t
654− 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
655677 getLine
656− release_display t
657− release_terminal t
678+ releaseDisplay t
679+ releaseTerminal t
658680 return ()
659− , print_summary = do
660− putStr $ [$heredoc|
681+ , printSummary = do
682+ putStr $ [s|
661683Once return is pressed:
662684 0. The screen will be cleared.
663685 1. The cursor will be hidden.
664686 2. 9 lines of text in three columns will be drawn:
665687 a. The first column will be a name of a standard color (for an 8 color
666− terminal) rendered with that color as the foreground color.
688+ terminal) rendered with that color as the foreground color.
667689 b. The next column will be also be the name of a standard color rendered
668690 with that color as the foreground color but the shade used should be
669− more vivid than the shade used in the first column.
691+ more vivid than the shade used in the first column.
670692 c. The final column will be the name of a color rendered with the
671693 default attributes.
672694
673695For instance, one line will be the word "magenta" and that word should be
674−rendered in the magenta color.
696+rendered in the magenta color.
675697
676698I'm not actually sure exactly what "vivid" means in this context. For xterm the
677−vivid colors are brighter.
699+vivid colors are brighter.
678700
679−Verify:
701+Verify:
680702 * The first column: The foreground color matches the named color.
681703 * The second column: The foreground color matches the named color but is
682− more vivid than the color used in the first column.
704+ more vivid than the color used in the first column.
683705 * The third column: All text is rendered with the default attributes.
684706 * The vertical bars used in each line to mark the border of a column are
685707 lined up.
@@ -688,58 +710,58 @@ After return is pressed for the second time:
688710 0. The screen containing the test summary should be restored.
689711 1. The cursor should be visible.
690712|]
691− , confirm_results = do
692− putStr $ [$heredoc|
713+ , confirmResults = do
714+ putStr $ [s|
693715Did the test output match the description?
694716|]
695− default_success_confirm_results
717+ defaultSuccessConfirmResults
696718 }
697719
698−attributes_test_3 = Test
699− { test_name = "Character attributes: Vivid background colors."
700− , test_ID = "attributes_test_3"
701− , test_action = do
702− t <- terminal_handle
703− reserve_display t
704− let pic = pic_for_image image
705− image = horiz_cat [border, column_0, border, column_1, border, column_2, border]
706− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
707− column_0 = vert_cat $ map line_with_color_0 all_colors
708− column_1 = vert_cat $ map line_with_color_1 all_bright_colors
709− column_2 = vert_cat $ map (string def_attr . snd) all_colors
710− line_with_color_0 (c, c_name) = string (def_attr `with_back_color` c) c_name
711− line_with_color_1 (c, c_name) = string (def_attr `with_back_color` c) c_name
712− d <- display_bounds t >>= display_context t
713− 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
714736 getLine
715− release_display t
716− release_terminal t
737+ releaseDisplay t
738+ releaseTerminal t
717739 return ()
718− , print_summary = do
719− putStr $ [$heredoc|
740+ , printSummary = do
741+ putStr $ [s|
720742Once return is pressed:
721743 0. The screen will be cleared.
722744 1. The cursor will be hidden.
723745 2. 9 lines of text in three columns will be drawn:
724746 a. The first column will contain be a name of a standard color for an 8
725747 color terminal rendered with the default foreground color with a
726− background the named color.
748+ background the named color.
727749 b. The first column will contain be a name of a standard color for an 8
728750 color terminal rendered with the default foreground color with the
729− background a vivid version of the named color.
751+ background a vivid version of the named color.
730752 c. The third column will be the name of a standard color rendered with
731753 the default attributes.
732−
754+
733755For instance, one line will contain be the word "magenta" and the word should
734−be rendered in the default foreground color over a magenta background.
756+be rendered in the default foreground color over a magenta background.
735757
736758I'm not actually sure exactly what "vivid" means in this context. For xterm the
737759vivid colors are brighter.
738760
739−Verify:
761+Verify:
740762 * The first column: The background color matches the named color.
741763 * The second column: The background color matches the named color and is
742− more vivid than the color used in the first column.
764+ more vivid than the color used in the first column.
743765 * The third column column: All text is rendered with the default attributes.
744766 * The vertical bars used in each line to mark the border of a column are
745767 lined up.
@@ -755,51 +777,51 @@ After return is pressed for the second time:
755777 0. The screen containing the test summary should be restored.
756778 1. The cursor should be visible.
757779|]
758− , confirm_results = do
759− putStr $ [$heredoc|
780+ , confirmResults = do
781+ putStr $ [s|
760782Did the test output match the description?
761783|]
762− default_success_confirm_results
784+ defaultSuccessConfirmResults
763785 }
764786
765−attr_combos =
787+attrCombos =
766788 [ ( "default", id )
767− , ( "bold", flip with_style bold )
768− , ( "blink", flip with_style blink )
769− , ( "underline", flip with_style underline )
770− , ( "bold + blink", flip with_style (bold + blink) )
771− , ( "bold + underline", flip with_style (bold + underline) )
772− , ( "underline + blink", flip with_style (underline + blink) )
773− , ( "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) )
774796 ]
775797
776−attributes_test_4 = Test
777− { test_name = "Character attributes: Bold; Blink; Underline."
778− , test_ID = "attributes_test_4"
779− , test_action = do
780− t <- terminal_handle
781− reserve_display t
782− let pic = pic_for_image image
783− image = horiz_cat [border, column_0, border, column_1, border]
784− border = vert_cat $ replicate (length attr_combos) $ string def_attr " | "
785− column_0 = vert_cat $ map line_with_attrs attr_combos
786− column_1 = vert_cat $ map (string def_attr . fst) attr_combos
787− line_with_attrs (desc, attr_f) = string (attr_f def_attr) desc
788− d <- display_bounds t >>= display_context t
789− 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
790812 getLine
791− release_display t
792− release_terminal t
813+ releaseDisplay t
814+ releaseTerminal t
793815 return ()
794− , print_summary = do
795− putStr $ [$heredoc|
816+ , printSummary = do
817+ putStr $ [s|
796818Once return is pressed:
797819 0. The screen will be cleared.
798820 1. The cursor will be hidden.
799− 2. 8 rows of text in two columns.
821+ 2. 8 rows of text in two columns.
800822 The rows will contain the following text:
801823 default
802− bold
824+ bold
803825 blink
804826 underline
805827 bold + blink
@@ -808,8 +830,8 @@ Once return is pressed:
808830 bold + blink + underline
809831 The first column will be rendered with the described attributes. The second
810832 column will be rendered with the default attributes.
811−
812−Verify:
833+
834+Verify:
813835 * The vertical bars used in each line to mark the border of a column are
814836 lined up.
815837 * The text in the first column is rendered as described.
@@ -818,86 +840,353 @@ After return is pressed for the second time:
818840 0. The screen containing the test summary should be restored.
819841 1. The cursor should be visible.
820842|]
821− , confirm_results = do
822− putStr $ [$heredoc|
843+ , confirmResults = do
844+ putStr $ [s|
823845Did the test output match the description?
824846|]
825− default_success_confirm_results
847+ defaultSuccessConfirmResults
826848 }
827849
828−attributes_test_5 = Test
829− { test_name = "Character attributes: 240 color palette"
830− , test_ID = "attributes_test_5"
831− , test_action = do
832− t <- terminal_handle
833− reserve_display t
834− let pic = pic_for_image image
835− image = vert_cat $ map horiz_cat $ split_color_images color_images
836− color_images = map (\i -> string (current_attr `with_back_color` Color240 i) " ") [0..239]
837− split_color_images [] = []
838− split_color_images is = (take 20 is ++ [string def_attr " "]) : (split_color_images (drop 20 is))
839− d <- display_bounds t >>= display_context t
840− 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
841863 getLine
842− release_display t
843− release_terminal t
864+ releaseDisplay t
865+ releaseTerminal t
844866 return ()
845− , print_summary = do
846− putStr $ [$heredoc|
867+ , printSummary = do
868+ putStr $ [s|
847869Once return is pressed:
848870 0. The screen will be cleared.
849871 1. The cursor will be hidden.
850872 2. A 20 character wide and 12 row high block of color squares. This should look like a palette
851873 of some sort. I'm not exactly sure if all color terminals use the same palette. I doubt it...
852874
853−Verify:
875+Verify:
854876
855877After return is pressed for the second time:
856878 0. The screen containing the test summary should be restored.
857879 1. The cursor should be visible.
858880|]
859− , confirm_results = do
860− putStr $ [$heredoc|
881+ , confirmResults = do
882+ putStr $ [s|
861883Did the test output match the description?
862884|]
863− default_success_confirm_results
885+ defaultSuccessConfirmResults
864886 }
865887
866−inline_test_0 = Test
867− { test_name = "Verify styled output can be performed without clearing the screen."
868− , test_ID = "inline_test_0"
869− , test_action = do
870− t <- terminal_handle
888+inlineTest0 = Test
889+ { testName = "Verify styled output can be performed without clearing the screen."
890+ , testID = "inlineTest0"
891+ , testAction = do
871892 putStrLn "line 1."
872− put_attr_change t $ back_color red >> apply_style underline
893+ putAttrChange_ $ backColor red >> applyStyle underline
873894 putStrLn "line 2."
874− put_attr_change t $ default_all
895+ putAttrChange_ $ defaultAll
875896 putStrLn "line 3."
876− release_terminal t
877− return ()
878− , print_summary = putStr $ [$heredoc|
897+ , printSummary = putStr $ [s|
879898lines are in order.
880899The second line "line 2" should have a red background and the text underline.
881900The third line "line 3" should be drawn in the same style as the first line.
882901|]
883902
884− , confirm_results = generic_output_match_confirm
903+ , confirmResults = genericOutputMatchConfirm
885904 }
886905
887−inline_test_1 = Test
888− { test_name = "Verify styled output can be performed without clearing the screen."
889− , test_ID = "inline_test_1"
890− , test_action = do
891− t <- terminal_handle
906+inlineTest1 = Test
907+ { testName = "Verify styled output can be performed without clearing the screen."
908+ , testID = "inlineTest1"
909+ , testAction = do
892910 putStr "Not styled. "
893− put_attr_change t $ back_color red >> apply_style underline
911+ putAttrChange_ $ backColor red >> applyStyle underline
894912 putStr " Styled! "
895− put_attr_change t $ default_all
913+ putAttrChange_ $ defaultAll
896914 putStrLn "Not styled."
897− release_terminal t
915+ , printSummary = putStr $ [s|
916+|]
917+
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
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
898947 return ()
899− , 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.
900954|]
955+ , confirmResults = genericOutputMatchConfirm
956+ }
901957
902− , 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
9031006 }
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+ }
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+