@@ -2,47 +2,49 @@
22{-# LANGUAGE ScopedTypeVariables #-}
33module Main where
44
5+import Graphics.Vty
56import Graphics.Vty.Attributes
6−import Graphics.Vty.Image
7+import Graphics.Vty.Inline
78import Graphics.Vty.Picture
8−import Graphics.Vty.Terminal
9−import Graphics.Vty.WinRegion
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
34−see onscreen. The goal is to verify that VTY's output and input support
36+see 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.
4244
4345Each test follows, more or less, the following format:
4446 0. A description of the test is printed which will include a detailed
45− description of what VTY is going to try and what the expected results are.
47+ description of what VTY is going to try and what the expected results are.
4648 Press return to move on.
4749 1. The program will produce some output or ask for you to press a key.
4850 2. You will then be asked to confirm if the behavior matched the provided
@@ -62,32 +64,42 @@ All the tests assume the following about the terminal display:
6264 describes the expected appearance of each glyph.
6365
6466Thanks for the help! :-D
65−|]
66− wait_for_return
67− results <- do_test_menu 1
68− env_attributes <- mapM ( \env_name -> catch ( Env.getEnv env_name >>= return . (,) env_name )
69− ( const $ return (env_name, "") )
70− )
71− [ "TERM", "COLORTERM", "LANG" ]
72− let results_txt = show env_attributes ++ "\n" ++ show results ++ "\n"
73− writeFile output_file_path results_txt
67+To exit the test early enter "q" anytime at the following menu screen.
7468
75−wait_for_return = do
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
7688 putStr "\n(press return to continue)"
7789 hFlush stdout
7890 getLine
7991
80−test_menu :: [(String, Test)]
81−test_menu = zip (map show [1..]) all_tests
92+testMenu :: [(String, Test)]
93+testMenu = zip (map show [1..]) allTests
8294
83−do_test_menu :: Int -> IO [(String, Bool)]
84−do_test_menu next_ID
85− | next_ID > length all_tests = do
86− putStrLn $ "Done! Please email the " ++ output_file_path ++ " file to coreyoconnor@gmail.com"
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"
8799 return []
88100 | otherwise = do
89− display_test_menu
90− putStrLn $ "Press return to start with #" ++ show next_ID ++ "."
101+ displayTestMenu
102+ putStrLn $ "Press return to start with #" ++ show nextID ++ "."
91103 putStrLn "Enter a test number to perform only that test."
92104 putStrLn "q (or control-C) to quit."
93105 putStr "> "
@@ -95,225 +107,246 @@ do_test_menu next_ID
95107 s <- getLine >>= return . filter (/= '\n')
96108 case s of
97109 "q" -> return mempty
98− "" -> do
99− r <- run_test $ show next_ID
100− rs <- do_test_menu ( next_ID + 1 )
110+ "" -> do
111+ r <- runTest $ show nextID
112+ rs <- doTestMenu ( nextID + 1 )
101113 return $ r : rs
102− i | isJust ( lookup i test_menu ) -> do
103− r <- run_test i
104− rs <- do_test_menu ( read i + 1 )
114+ i | isJust ( lookup i testMenu ) -> do
115+ r <- runTest i
116+ rs <- doTestMenu ( read i + 1 )
105117 return $ r : rs
106118 where
107− display_test_menu
108− = mapM_ display_test_menu' test_menu
109− display_test_menu' ( i, t )
110− = putStrLn $ ( if i == show next_ID
111− then "> "
119+ displayTestMenu
120+ = mapM_ displayTestMenu' testMenu
121+ displayTestMenu' ( i, t )
122+ = putStrLn $ ( if i == show nextID
123+ then "> "
112124 else " "
113− ) ++ i ++ ". " ++ test_name t
114−
115−run_test :: String -> IO (String, Bool)
116−run_test i = do
117− let t = fromJust $ lookup i test_menu
118− print_summary t
119− wait_for_return
120− test_action t
121− r <- confirm_results t
122− return (test_ID t, r)
123−
124−default_success_confirm_results = do
125+ ) ++ 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
125137 putStr "\n"
126138 putStr "[Y/n] "
127139 hFlush stdout
128140 r <- getLine
129141 case r of
130− "" -> return True
142+ "" -> return True
131143 "y" -> return True
132144 "Y" -> return True
133145 "n" -> return False
134146
135147data Test = Test
136− { test_name :: String
137− , test_ID :: String
138− , test_action :: IO ()
139− , print_summary :: IO ()
140− , confirm_results :: IO Bool
148+ { testName :: String
149+ , testID :: String
150+ , testAction :: IO ()
151+ , printSummary :: IO ()
152+ , confirmResults :: IO Bool
141153 }
142154
143−all_tests
144− = [ reserve_output_test
145− , display_bounds_test_0
146− , display_bounds_test_1
147− , display_bounds_test_2
148− , display_bounds_test_3
149− , unicode_single_width_0
150− , unicode_single_width_1
151− , unicode_double_width_0
152− , unicode_double_width_1
153− , attributes_test_0
154− , attributes_test_1
155− , attributes_test_2
156− , attributes_test_3
157− , attributes_test_4
158− , attributes_test_5
159− , inline_test_0
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
160185 ]
161186
162−reserve_output_test = Test
163− { test_name = "Initialize and reserve terminal output then restore previous state."
164− , test_ID = "reserve_output_test"
165− , test_action = do
166− t <- terminal_handle
167− 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
168193 putStrLn "Line 1"
169194 putStrLn "Line 2"
170195 putStrLn "Line 3"
171196 putStrLn "Line 4 (press return)"
172197 hFlush stdout
173198 getLine
174− release_display t
175− release_terminal t
199+ releaseDisplay t
200+ releaseTerminal t
176201 return ()
177− , print_summary = do
178− putStr $ [$heredoc|
202+ , printSummary = do
203+ putStr $ [s|
179204Once return is pressed:
180−The screen will be cleared.
181−The cursor should be visible and at the top left corner.
182−Four lines of text should be visible.
205+ 0. The screen will be cleared.
206+ 1. Four lines of text should be visible.
207+ 1. The cursor should be visible and at the start of the fifth line.
183208
184−After enter is pressed for the second time this test then:
209+After return is pressed for the second time this test then:
185210 * The screen containing the test summary should be restored;
186211 * The cursor is visible.
187212|]
188− , confirm_results = do
189− putStr $ [$heredoc|
213+ , confirmResults = do
214+ putStr $ [s|
190215Did the test output match the description?
191216|]
192− default_success_confirm_results
217+ defaultSuccessConfirmResults
193218 }
194219
195−display_bounds_test_0 = Test
196− { test_name = "Verify display bounds are correct test 0: Using spaces."
197− , test_ID = "display_bounds_test_0"
198− , test_action = do
199− t <- terminal_handle
200− reserve_display t
201− DisplayBounds w h <- display_bounds t
202− let row_0 = replicate (fromEnum w) 'X' ++ "\n"
203− row_h = replicate (fromEnum w - 1) 'X'
204− row_n = "X" ++ replicate (fromEnum w - 2) ' ' ++ "X\n"
205− 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
206231 putStr image
207232 hFlush stdout
208233 getLine
209− release_display t
210− release_terminal t
234+ releaseDisplay t
235+ releaseTerminal t
211236 return ()
212− , print_summary = display_bounds_test_summary True
213− , confirm_results = generic_output_match_confirm
237+ , printSummary = displayBoundsTestSummary True
238+ , confirmResults = genericOutputMatchConfirm
214239 }
215240
216−display_bounds_test_1 = Test
217− { test_name = "Verify display bounds are correct test 0: Using cursor movement."
218− , test_ID = "display_bounds_test_1"
219− , test_action = do
220− t <- terminal_handle
221− reserve_display t
222− DisplayBounds w h <- display_bounds t
223− set_cursor_pos t 0 0
224− let row_0 = replicate (fromEnum w) 'X' ++ "\n"
225− 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
226251 forM_ [1 .. h - 2] $ \y -> do
227− set_cursor_pos t 0 y
252+ setCursorPos t 0 y
228253 putStr "X"
229− set_cursor_pos t (w - 1) y
254+ hFlush stdout
255+ setCursorPos t (w - 1) y
230256 putStr "X"
231− set_cursor_pos t 0 (h - 1)
232− let row_h = replicate (fromEnum w - 1) 'X'
233− putStr row_h
257+ hFlush stdout
258+ setCursorPos t 0 (h - 1)
259+ let rowH = replicate (fromEnum w - 1) 'X'
260+ putStr rowH
234261 hFlush stdout
235262 getLine
236− release_display t
237− release_terminal t
263+ releaseDisplay t
264+ releaseTerminal t
238265 return ()
239− , print_summary = display_bounds_test_summary True
240− , confirm_results = generic_output_match_confirm
266+ , printSummary = displayBoundsTestSummary True
267+ , confirmResults = genericOutputMatchConfirm
241268 }
242269
243−display_bounds_test_2 = Test
244− { test_name = "Verify display bounds are correct test 0: Using Image ops."
245− , test_ID = "display_bounds_test_2"
246− , test_action = do
247− t <- terminal_handle
248− reserve_display t
249− bounds@(DisplayBounds w h) <- display_bounds t
250− let first_row = horiz_cat $ replicate (fromEnum w) (char def_attr 'X')
251− middle_rows = vert_cat $ replicate (fromEnum h - 2) middle_row
252− middle_row = (char def_attr 'X') <|> background_fill (w - 2) 1 <|> (char def_attr 'X')
253− end_row = first_row
254− image = first_row <-> middle_rows <-> end_row
255− pic = (pic_for_image image) { pic_cursor = Cursor (w - 1) (h - 1) }
256− d <- display_context t bounds
257− 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
258285 getLine
259− release_display t
260− release_terminal t
286+ releaseDisplay t
287+ releaseTerminal t
261288 return ()
262− , print_summary = display_bounds_test_summary True
263− , confirm_results = generic_output_match_confirm
289+ , printSummary = displayBoundsTestSummary True
290+ , confirmResults = genericOutputMatchConfirm
264291 }
265292
266−display_bounds_test_3 = Test
267− { test_name = "Verify display bounds are correct test 0: Hide cursor; Set cursor pos."
268− , test_ID = "display_bounds_test_3"
269− , test_action = do
270− t <- terminal_handle
271− reserve_display t
272− DisplayBounds w h <- display_bounds t
273− hide_cursor t
274− set_cursor_pos t 0 0
275− let row_0 = replicate (fromEnum w) 'X'
276− 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
277304 forM_ [1 .. h - 2] $ \y -> do
278− set_cursor_pos t 0 y
305+ setCursorPos t 0 y
279306 putStr "X"
280− set_cursor_pos t (w - 1) y
307+ hFlush stdout
308+ setCursorPos t (w - 1) y
281309 putStr "X"
282− set_cursor_pos t 0 (h - 1)
283− let row_h = row_0
284− putStr row_h
310+ hFlush stdout
311+ setCursorPos t 0 (h - 1)
312+ let rowH = row0
313+ putStr rowH
285314 hFlush stdout
286315 getLine
287− show_cursor t
288− release_display t
289− release_terminal t
316+ showCursor t
317+ releaseDisplay t
318+ releaseTerminal t
290319 return ()
291− , print_summary = display_bounds_test_summary False
292− , confirm_results = generic_output_match_confirm
320+ , printSummary = displayBoundsTestSummary False
321+ , confirmResults = genericOutputMatchConfirm
293322 }
294323
295−display_bounds_test_summary has_cursor = do
296− putStr $ [$heredoc|
324+displayBoundsTestSummary hasCursor = do
325+ putStr $ [s|
297326Once return is pressed:
298327 0. The screen will be cleared.
299328|]
300− if has_cursor
329+ if hasCursor
301330 then putStr " 1. The cursor will be visible."
302331 else putStr " 1. The cursor will NOT be visible."
303− putStr [$heredoc|
332+ putStr [s|
333+
304334 2. The border of the display will be outlined in Xs.
305335 So if - and | represented the edge of the terminal window:
306336 |-------------|
307337 |XXXXXXXXXXXXX|
308338 |X X||]
309339
310− if has_cursor
311− then putStr $ [$heredoc|
340+ if hasCursor
341+ then putStr $ [s|
342+
312343 |XXXXXXXXXXXXC| |]
313− else putStr $ [$heredoc|
344+ else putStr $ [s|
345+
314346 |XXXXXXXXXXXXX| |]
315347
316− putStr $ [$heredoc|
348+ putStr $ [s|
349+
317350 |-------------|
318351
319352 ( Where C is the final position of the cursor. There may be an X drawn
@@ -325,13 +358,13 @@ After return is pressed for the second time:
325358 1. The cursor should be visible.
326359|]
327360
328−generic_output_match_confirm = do
329− putStr $ [$heredoc|
361+genericOutputMatchConfirm = do
362+ putStr $ [s|
330363Did the test output match the description?
331364|]
332− default_success_confirm_results
365+ defaultSuccessConfirmResults
333366
334−-- Explicitely definethe bytes that encode each example text.
367+-- Explicitly define the bytes that encode each example text.
335368-- This avoids any issues with how the compiler represents string literals.
336369--
337370-- This document is UTF-8 encoded so the UTF-8 string is still included for
@@ -340,24 +373,24 @@ Did the test output match the description?
340373-- It's assumed the compiler will at least not barf on UTF-8 encoded text in
341374-- comments ;-)
342375--
343−-- txt_0 = ↑↑↓↓←→←→BA
344−
345−utf8_txt_0 :: [[Word8]]
346−utf8_txt_0 = [ [ 0xe2 , 0x86 , 0x91 ]
347− , [ 0xe2 , 0x86 , 0x91 ]
348− , [ 0xe2 , 0x86 , 0x93 ]
349− , [ 0xe2 , 0x86 , 0x93 ]
350− , [ 0xe2 , 0x86 , 0x90 ]
351− , [ 0xe2 , 0x86 , 0x92 ]
352− , [ 0xe2 , 0x86 , 0x90 ]
353− , [ 0xe2 , 0x86 , 0x92 ]
354− , [ 0x42 ]
355− , [ 0x41 ]
356− ]
357−
358−iso_10646_txt_0 :: String
359−iso_10646_txt_0 = map toEnum
360− [ 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
361394 , 8593
362395 , 8595
363396 , 8595
@@ -369,45 +402,46 @@ iso_10646_txt_0 = map toEnum
369402 , 65
370403 ]
371404
372−unicode_single_width_0 = Test
373− { test_name = "Verify terminal can display unicode single-width characters. (Direct UTF-8)"
374− , test_ID = "unicode_single_width_0"
375− , test_action = do
376− t <- terminal_handle
377− reserve_display t
378− 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)
379413 hPutStr stdout "\n"
380414 hPutStr stdout "0123456789\n"
381415 hFlush stdout
382416 getLine
383− release_display t
384− release_terminal t
417+ releaseDisplay t
418+ releaseTerminal t
385419 return ()
386− , print_summary = unicode_single_width_summary
387− , confirm_results = generic_output_match_confirm
420+ , printSummary = unicodeSingleWidthSummary
421+ , confirmResults = genericOutputMatchConfirm
388422 }
389423
390−unicode_single_width_1 = Test
391− { test_name = "Verify terminal can display unicode single-width characters. (Image ops)"
392− , test_ID = "unicode_single_width_1"
393− , test_action = do
394− t <- terminal_handle
395− reserve_display t
396− let pic = pic_for_image image
397− image = line_0 <-> line_1
398− line_0 = iso_10646_string def_attr iso_10646_txt_0
399− line_1 = string def_attr "0123456789"
400− d <- display_bounds t >>= display_context t
401− 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
402436 getLine
403− release_display t
404− release_terminal t
437+ releaseDisplay t
438+ releaseTerminal t
405439 return ()
406− , print_summary = unicode_single_width_summary
407− , confirm_results = generic_output_match_confirm
440+ , printSummary = unicodeSingleWidthSummary
441+ , confirmResults = genericOutputMatchConfirm
408442 }
409443
410−unicode_single_width_summary = putStr [$heredoc|
444+unicodeSingleWidthSummary = putStr [s|
411445Once return is pressed:
412446 0. The screen will be cleared.
413447 1. The cursor will be hidden.
@@ -441,54 +475,55 @@ After return is pressed for the second time:
441475
442476-- The second example is a unicode string containing double-width glyphs
443477-- 你好吗
444−utf8_txt_1 :: [[Word8]]
445−utf8_txt_1 = [ [0xe4,0xbd,0xa0]
446− , [0xe5,0xa5,0xbd]
447− , [0xe5,0x90,0x97]
448− ]
449−
450−iso_10646_txt_1 :: String
451−iso_10646_txt_1 = map toEnum [20320,22909,21527]
452−
453−unicode_double_width_0 = Test
454− { test_name = "Verify terminal can display unicode double-width characters. (Direct UTF-8)"
455− , test_ID = "unicode_double_width_0"
456− , test_action = do
457− t <- terminal_handle
458− reserve_display t
459− 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)
460495 hPutStr stdout "\n"
461496 hPutStr stdout "012345\n"
462497 hFlush stdout
463498 getLine
464− release_display t
465− release_terminal t
499+ releaseDisplay t
500+ releaseTerminal t
466501 return ()
467− , print_summary = unicode_double_width_summary
468− , confirm_results = generic_output_match_confirm
502+ , printSummary = unicodeDoubleWidthSummary
503+ , confirmResults = genericOutputMatchConfirm
469504 }
470505
471−unicode_double_width_1 = Test
472− { test_name = "Verify terminal can display unicode double-width characters. (Image ops)"
473− , test_ID = "unicode_double_width_1"
474− , test_action = do
475− t <- terminal_handle
476− reserve_display t
477− let pic = pic_for_image image
478− image = line_0 <-> line_1
479− line_0 = iso_10646_string def_attr iso_10646_txt_1
480− line_1 = string def_attr "012345"
481− d <- display_bounds t >>= display_context t
482− 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
483518 getLine
484− release_display t
485− release_terminal t
519+ releaseDisplay t
520+ releaseTerminal t
486521 return ()
487− , print_summary = unicode_double_width_summary
488− , confirm_results = generic_output_match_confirm
522+ , printSummary = unicodeDoubleWidthSummary
523+ , confirmResults = genericOutputMatchConfirm
489524 }
490525
491−unicode_double_width_summary = putStr [$heredoc|
526+unicodeDoubleWidthSummary = putStr [s|
492527Once return is pressed:
493528 0. The screen will be cleared.
494529 1. The cursor will be hidden.
@@ -515,29 +550,33 @@ After return is pressed for the second time:
515550 1. The cursor should be visible.
516551|]
517552
518−all_colors = zip [ black, red, green, yellow, blue, magenta, cyan, white, def ]
519− [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white", "default" ]
520−
521−attributes_test_0 = Test
522− { test_name = "Character attributes: foreground colors."
523− , test_ID = "attributes_test_0"
524− , test_action = do
525− t <- terminal_handle
526− reserve_display t
527− let pic = pic_for_image image
528− image = border <|> column_0 <|> border <|> column_1 <|> border
529− column_0 = vert_cat $ map line_with_color all_colors
530− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
531− column_1 = vert_cat $ map (string def_attr . snd) all_colors
532− line_with_color (c_value, c_name) = string (setFG c_value def_attr) c_name
533− d <- display_bounds t >>= display_context t
534− output_picture d pic
553+allColors = zip [ black, red, green, yellow, blue, magenta, cyan, white ]
554+ [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ]
555+
556+allBrightColors
557+ = zip [ brightBlack, brightRed, brightGreen, brightYellow, brightBlue, brightMagenta, brightCyan, brightWhite ]
558+ [ "bright black", "bright red", "bright green", "bright yellow", "bright blue", "bright magenta", "bright cyan", "bright white" ]
559+
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
535574 getLine
536− release_display t
537− release_terminal t
575+ releaseDisplay t
576+ releaseTerminal t
538577 return ()
539− , print_summary = do
540− putStr $ [$heredoc|
578+ , printSummary = do
579+ putStr $ [s|
541580Once return is pressed:
542581 0. The screen will be cleared.
543582 1. The cursor will be hidden.
@@ -557,40 +596,40 @@ After return is pressed for the second time:
557596 0. The screen containing the test summary should be restored.
558597 1. The cursor should be visible.
559598|]
560− , confirm_results = do
561− putStr $ [$heredoc|
599+ , confirmResults = do
600+ putStr $ [s|
562601Did the test output match the description?
563602|]
564− default_success_confirm_results
603+ defaultSuccessConfirmResults
565604 }
566605
567−attributes_test_1 = Test
568− { test_name = "Character attributes: background colors."
569− , test_ID = "attributes_test_1"
570− , test_action = do
571− t <- terminal_handle
572− reserve_display t
573− let pic = pic_for_image image
574− image = border <|> column_0 <|> border <|> column_1 <|> border
575− column_0 = vert_cat $ map line_with_color all_colors
576− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
577− column_1 = vert_cat $ map (string def_attr . snd) all_colors
578− line_with_color (c_value, c_name) = string (setBG c_value def_attr) c_name
579− d <- display_bounds t >>= display_context t
580− 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
581620 getLine
582− release_display t
583− release_terminal t
621+ releaseDisplay t
622+ releaseTerminal t
584623 return ()
585− , print_summary = do
586− putStr $ [$heredoc|
624+ , printSummary = do
625+ putStr $ [s|
587626Once return is pressed:
588627 0. The screen will be cleared.
589628 1. The cursor will be hidden.
590629 2. 9 lines of text in two columns will be drawn. The first column will
591630 contain be a name of a standard color for an 8 color terminal rendered with
592631 the default foreground color with a background the named color. For
593− instance, one line will contain be the word "magenta" and that words should
632+ instance, one line will contain be the word "magenta" and the word should
594633 be rendered in the default foreground color over a magenta background. The
595634 second column will be the name of a standard color rendered with the default
596635 attributes.
@@ -612,57 +651,57 @@ After return is pressed for the second time:
612651 0. The screen containing the test summary should be restored.
613652 1. The cursor should be visible.
614653|]
615− , confirm_results = do
616− putStr $ [$heredoc|
654+ , confirmResults = do
655+ putStr $ [s|
617656Did the test output match the description?
618657|]
619− default_success_confirm_results
658+ defaultSuccessConfirmResults
620659 }
621660
622−attributes_test_2 = Test
623− { test_name = "Character attributes: Vivid foreground colors."
624− , test_ID = "attributes_test_2"
625− , test_action = do
626− t <- terminal_handle
627− reserve_display t
628− let pic = pic_for_image image
629− image = horiz_cat [border, column_0, border, column_1, border, column_2, border]
630− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
631− column_0 = vert_cat $ map line_with_color_0 all_colors
632− column_1 = vert_cat $ map line_with_color_1 all_colors
633− column_2 = vert_cat $ map (string def_attr . snd) all_colors
634− line_with_color_0 (c_value, c_name) = string (setFG c_value def_attr) c_name
635− line_with_color_1 (c_value, c_name) = string (setFGVivid c_value def_attr) c_name
636− d <- display_bounds t >>= display_context t
637− 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
638677 getLine
639− release_display t
640− release_terminal t
678+ releaseDisplay t
679+ releaseTerminal t
641680 return ()
642− , print_summary = do
643− putStr $ [$heredoc|
681+ , printSummary = do
682+ putStr $ [s|
644683Once return is pressed:
645684 0. The screen will be cleared.
646685 1. The cursor will be hidden.
647686 2. 9 lines of text in three columns will be drawn:
648687 a. The first column will be a name of a standard color (for an 8 color
649− terminal) rendered with that color as the foreground color.
688+ terminal) rendered with that color as the foreground color.
650689 b. The next column will be also be the name of a standard color rendered
651690 with that color as the foreground color but the shade used should be
652− more vivid than the shade used in the first column.
691+ more vivid than the shade used in the first column.
653692 c. The final column will be the name of a color rendered with the
654693 default attributes.
655694
656695For instance, one line will be the word "magenta" and that word should be
657−rendered in the magenta color.
696+rendered in the magenta color.
658697
659698I'm not actually sure exactly what "vivid" means in this context. For xterm the
660−vivid colors are brighter.
699+vivid colors are brighter.
661700
662−Verify:
701+Verify:
663702 * The first column: The foreground color matches the named color.
664703 * The second column: The foreground color matches the named color but is
665− more vivid than the color used in the first column.
704+ more vivid than the color used in the first column.
666705 * The third column: All text is rendered with the default attributes.
667706 * The vertical bars used in each line to mark the border of a column are
668707 lined up.
@@ -671,58 +710,58 @@ After return is pressed for the second time:
671710 0. The screen containing the test summary should be restored.
672711 1. The cursor should be visible.
673712|]
674− , confirm_results = do
675− putStr $ [$heredoc|
713+ , confirmResults = do
714+ putStr $ [s|
676715Did the test output match the description?
677716|]
678− default_success_confirm_results
717+ defaultSuccessConfirmResults
679718 }
680719
681−attributes_test_3 = Test
682− { test_name = "Character attributes: vivid background colors."
683− , test_ID = "attributes_test_3"
684− , test_action = do
685− t <- terminal_handle
686− reserve_display t
687− let pic = pic_for_image image
688− image = horiz_cat [border, column_0, border, column_1, border, column_2, border]
689− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "
690− column_0 = vert_cat $ map line_with_color_0 all_colors
691− column_1 = vert_cat $ map line_with_color_1 all_colors
692− column_2 = vert_cat $ map (string def_attr . snd) all_colors
693− line_with_color_0 (c_value, c_name) = string (setBG c_value def_attr) c_name
694− line_with_color_1 (c_value, c_name) = string (setBGVivid c_value def_attr) c_name
695− d <- display_bounds t >>= display_context t
696− 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
697736 getLine
698− release_display t
699− release_terminal t
737+ releaseDisplay t
738+ releaseTerminal t
700739 return ()
701− , print_summary = do
702− putStr $ [$heredoc|
740+ , printSummary = do
741+ putStr $ [s|
703742Once return is pressed:
704743 0. The screen will be cleared.
705744 1. The cursor will be hidden.
706745 2. 9 lines of text in three columns will be drawn:
707746 a. The first column will contain be a name of a standard color for an 8
708747 color terminal rendered with the default foreground color with a
709− background the named color.
748+ background the named color.
710749 b. The first column will contain be a name of a standard color for an 8
711750 color terminal rendered with the default foreground color with the
712− background a vivid version of the named color.
751+ background a vivid version of the named color.
713752 c. The third column will be the name of a standard color rendered with
714753 the default attributes.
715−
716−For instance, one line will contain be the word "magenta" and that words should
717−be rendered in the default foreground color over a magenta background.
754+
755+For instance, one line will contain be the word "magenta" and the word should
756+be rendered in the default foreground color over a magenta background.
718757
719758I'm not actually sure exactly what "vivid" means in this context. For xterm the
720759vivid colors are brighter.
721760
722−Verify:
761+Verify:
723762 * The first column: The background color matches the named color.
724763 * The second column: The background color matches the named color and is
725− more vivid than the color used in the first column.
764+ more vivid than the color used in the first column.
726765 * The third column column: All text is rendered with the default attributes.
727766 * The vertical bars used in each line to mark the border of a column are
728767 lined up.
@@ -738,51 +777,51 @@ After return is pressed for the second time:
738777 0. The screen containing the test summary should be restored.
739778 1. The cursor should be visible.
740779|]
741− , confirm_results = do
742− putStr $ [$heredoc|
780+ , confirmResults = do
781+ putStr $ [s|
743782Did the test output match the description?
744783|]
745− default_success_confirm_results
784+ defaultSuccessConfirmResults
746785 }
747786
748−attr_combos =
749− [ ("default", id)
750− , ("bold", setBold)
751− , ("blink", setBlink)
752− , ("underline", setUnderline)
753− , ("bold + blink", setBlink . setBold)
754− , ("bold + underline", setUnderline . setBold)
755− , ("underline + blink", setBlink . setUnderline)
756− , ("bold + blink + underline", setUnderline . setBlink . setBold)
787+attrCombos =
788+ [ ( "default", id )
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) )
757796 ]
758797
759−attributes_test_4 = Test
760− { test_name = "Character attributes: Bold; Blink; Underline."
761− , test_ID = "attributes_test_4"
762− , test_action = do
763− t <- terminal_handle
764− reserve_display t
765− let pic = pic_for_image image
766− image = horiz_cat [border, column_0, border, column_1, border]
767− border = vert_cat $ replicate (length attr_combos) $ string def_attr " | "
768− column_0 = vert_cat $ map line_with_attrs attr_combos
769− column_1 = vert_cat $ map (string def_attr . fst) attr_combos
770− line_with_attrs (desc, attr_f) = string (attr_f def_attr) desc
771− d <- display_bounds t >>= display_context t
772− 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
773812 getLine
774− release_display t
775− release_terminal t
813+ releaseDisplay t
814+ releaseTerminal t
776815 return ()
777− , print_summary = do
778− putStr $ [$heredoc|
816+ , printSummary = do
817+ putStr $ [s|
779818Once return is pressed:
780819 0. The screen will be cleared.
781820 1. The cursor will be hidden.
782− 2. 8 rows of text in two columns.
821+ 2. 8 rows of text in two columns.
783822 The rows will contain the following text:
784823 default
785− bold
824+ bold
786825 blink
787826 underline
788827 bold + blink
@@ -791,8 +830,8 @@ Once return is pressed:
791830 bold + blink + underline
792831 The first column will be rendered with the described attributes. The second
793832 column will be rendered with the default attributes.
794−
795−Verify:
833+
834+Verify:
796835 * The vertical bars used in each line to mark the border of a column are
797836 lined up.
798837 * The text in the first column is rendered as described.
@@ -801,66 +840,353 @@ After return is pressed for the second time:
801840 0. The screen containing the test summary should be restored.
802841 1. The cursor should be visible.
803842|]
804− , confirm_results = do
805− putStr $ [$heredoc|
843+ , confirmResults = do
844+ putStr $ [s|
806845Did the test output match the description?
807846|]
808− default_success_confirm_results
847+ defaultSuccessConfirmResults
809848 }
810849
811−attributes_test_5 = Test
812− { test_name = "Character attributes: 240 color palette"
813− , test_ID = "attributes_test_5"
814− , test_action = do
815− t <- terminal_handle
816− reserve_display t
817− let pic = pic_for_image image
818− image = vert_cat $ map horiz_cat $ split_color_images color_images
819− color_images = map (\i -> string (current_attr `with_back_color` Color240 i) " ") [0..239]
820− split_color_images [] = []
821− split_color_images is = (take 20 is ++ [string def_attr " "]) : (split_color_images (drop 20 is))
822− d <- display_bounds t >>= display_context t
823− 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
824863 getLine
825− release_display t
826− release_terminal t
864+ releaseDisplay t
865+ releaseTerminal t
827866 return ()
828− , print_summary = do
829− putStr $ [$heredoc|
867+ , printSummary = do
868+ putStr $ [s|
830869Once return is pressed:
831870 0. The screen will be cleared.
832871 1. The cursor will be hidden.
833872 2. A 20 character wide and 12 row high block of color squares. This should look like a palette
834873 of some sort. I'm not exactly sure if all color terminals use the same palette. I doubt it...
835874
836−Verify:
875+Verify:
837876
838877After return is pressed for the second time:
839878 0. The screen containing the test summary should be restored.
840879 1. The cursor should be visible.
841880|]
842− , confirm_results = do
843− putStr $ [$heredoc|
881+ , confirmResults = do
882+ putStr $ [s|
844883Did the test output match the description?
845884|]
846− default_success_confirm_results
885+ defaultSuccessConfirmResults
847886 }
848887
849−inline_test_0 = Test
850− { test_name = "Verify styled output can be performed without clearing the screen."
851− , test_ID = "inline_test_0"
852− , test_action = do
853− t <- terminal_handle
854− d <- display_bounds t >>= display_context t
855− let image = string ( def_attr `with_back_color` red ) "line 1."
856− putStrLn "line 0."
857− put_image_ln d image
888+inlineTest0 = Test
889+ { testName = "Verify styled output can be performed without clearing the screen."
890+ , testID = "inlineTest0"
891+ , testAction = do
892+ putStrLn "line 1."
893+ putAttrChange_ $ backColor red >> applyStyle underline
858894 putStrLn "line 2."
859− release_terminal t
860− return ()
861− , print_summary = putStr $ [$heredoc|
895+ putAttrChange_ $ defaultAll
896+ putStrLn "line 3."
897+ , printSummary = putStr $ [s|
862898lines are in order.
899+The second line "line 2" should have a red background and the text underline.
900+The third line "line 3" should be drawn in the same style as the first line.
901+|]
902+
903+ , confirmResults = genericOutputMatchConfirm
904+ }
905+
906+inlineTest1 = Test
907+ { testName = "Verify styled output can be performed without clearing the screen."
908+ , testID = "inlineTest1"
909+ , testAction = do
910+ putStr "Not styled. "
911+ putAttrChange_ $ backColor red >> applyStyle underline
912+ putStr " Styled! "
913+ putAttrChange_ $ defaultAll
914+ putStrLn "Not styled."
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
947+ return ()
948+ , printSummary = putStr $ [s|
949+ 1. verify the cursor is displayed.
950+ 2. press enter
951+ 3. verify the cursor is hid.
952+ 4. press enter.
953+ 5. the display should return to the state before the test.
954+|]
955+ , confirmResults = genericOutputMatchConfirm
956+ }
957+
958+outputImageAndWait :: Image -> IO ()
959+outputImageAndWait image = do
960+ let pic = picForImage image
961+ outputPicAndWait pic
962+
963+outputPicAndWait :: Picture -> IO ()
964+outputPicAndWait pic = do
965+ t <- standardIOConfig >>= outputForConfig
966+ reserveDisplay t
967+ d <- displayBounds t >>= displayContext t
968+ outputPicture d pic
969+ getLine
970+ releaseDisplay t
971+ releaseTerminal t
972+ return ()
973+
974+vertCropTest0 :: Test
975+vertCropTest0 = Test
976+ { testName = "Verify bottom cropping works as expected with single column chars"
977+ , testID = "cropTest0"
978+ , testAction = do
979+ let block0 = cropBottom 2 $ vertCat $ map (string defAttr) lorumIpsum
980+ block1 = vertCat $ map (string defAttr) $ take 2 lorumIpsum
981+ image = block0 <-> backgroundFill 10 2 <-> block1
982+ outputImageAndWait image
983+ , printSummary = putStr $ [s|
984+ 1. Verify the two text blocks are identical.
985+ 2. press enter.
986+ 3. the display should return to the state before the test.
863987|]
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
1006+ }
1007+
1008+vertCropTest2 :: Test
1009+vertCropTest2 = Test
1010+ { testName = "Verify top cropping works as expected with single column chars"
1011+ , testID = "cropTest2"
1012+ , testAction = do
1013+ let block0 = cropTop 2 $ vertCat $ map (string defAttr) lorumIpsum
1014+ block1 = vertCat $ map (string defAttr) $ drop (length lorumIpsum - 2) lorumIpsum
1015+ image = block0 <-> backgroundFill 10 2 <-> block1
1016+ outputImageAndWait image
1017+ , printSummary = putStr $ [s|
1018+ 1. Verify the two text blocks are identical.
1019+ 2. press enter.
1020+ 3. the display should return to the state before the test.
1021+|]
1022+ , confirmResults = genericOutputMatchConfirm
1023+ }
1024+
1025+vertCropTest3 :: Test
1026+vertCropTest3 = Test
1027+ { testName = "Verify top cropping works as expected with double column chars"
1028+ , testID = "cropTest0"
1029+ , testAction = do
1030+ let block0 = cropTop 2 $ vertCat $ map (string defAttr) lorumIpsumChinese
1031+ block1 = vertCat $ map (string defAttr) $ drop (length lorumIpsumChinese - 2 ) lorumIpsumChinese
1032+ image = block0 <-> backgroundFill 10 2 <-> block1
1033+ outputImageAndWait image
1034+ , printSummary = putStr $ [s|
1035+ 1. Verify the two text blocks are identical.
1036+ 2. press enter.
1037+ 3. the display should return to the state before the test.
1038+|]
1039+ , confirmResults = genericOutputMatchConfirm
1040+ }
1041+
1042+horizCropTest0 :: Test
1043+horizCropTest0 = Test
1044+ { testName = "Verify right cropping works as expected with single column chars"
1045+ , testID = "cropTest0"
1046+ , testAction = do
1047+ let baseImage = vertCat $ map (string defAttr) lorumIpsum
1048+ croppedImage = cropRight (imageWidth baseImage `div` 2) baseImage
1049+ image = baseImage <-> backgroundFill 10 2 <-> croppedImage
1050+ outputImageAndWait image
1051+ , printSummary = putStr $ [s|
1052+ 1. Verify the bottom text block is about half the width of the top text block.
1053+ 2. press enter.
1054+ 3. the display should return to the state before the test.
1055+|]
1056+ , confirmResults = genericOutputMatchConfirm
1057+ }
8641058
865− , confirm_results = generic_output_match_confirm
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
8661074 }
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+