@@ -2,42 +2,41 @@
22{-# LANGUAGE ScopedTypeVariables #-}
33module Main where
44
5−import Graphics.Vty
65import Graphics.Vty.Attributes
6+import Graphics.Vty.Image
77import Graphics.Vty.Inline
88import Graphics.Vty.Picture
9−import Graphics.Vty.Output
9+import Graphics.Vty.Terminal
10+import Graphics.Vty.DisplayRegion
1011
11−import Control.Concurrent (threadDelay)
12−import Control.Exception
1312import Control.Monad
1413
1514import Data.List ( lookup )
1615import Data.Maybe ( isJust, fromJust )
1716import Data.Monoid
18−import Data.String.QQ
1917import Data.Word
2018
21−import Foreign.Marshal.Array
19+import Foreign.Marshal.Array
20+import HereDoc
2221
2322import qualified System.Environment as Env
2423
2524import System.IO ( hFlush, hPutStr, hPutBuf, stdout )
2625
2726main = do
28− printIntro
27+ print_intro
2928
30−outputFilePath = "test_results.list"
29+output_file_path = "test_results.list"
3130
32−printIntro = do
33− putStr $ [s|
31+print_intro = do
32+ putStr $ [$heredoc|
3433This is an interactive verification program for the terminal input and output
3534support of the VTY library. This will ask a series of questions about what you
3635see on screen. The goal is to verify that VTY's output and input support
3736performs as expected with your terminal.
3837
3938This program produces a file named
40− |] ++ outputFilePath ++ [s|
39+ |] ++ output_file_path ++ [$heredoc|
4140in the current directory that contains the results for each test assertion. This
4241can be emailed to coreyoconnor@gmail.com and used by the VTY authors to improve
4342support for your terminal. No personal information is contained in the report.
@@ -63,43 +62,42 @@ All the tests assume the following about the terminal display:
6362 a good range of the unicode characters. Each test involving unicode display
6463 describes the expected appearance of each glyph.
6564
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
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
8886 putStr "\n(press return to continue)"
8987 hFlush stdout
9088 getLine
9189
92−testMenu :: [(String, Test)]
93−testMenu = zip (map show [1..]) allTests
90+test_menu :: [(String, Test)]
91+test_menu = zip (map show [1..]) all_tests
9492
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"
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"
9997 return []
10098 | otherwise = do
101− displayTestMenu
102− putStrLn $ "Press return to start with #" ++ show nextID ++ "."
99+ display_test_menu
100+ putStrLn $ "Press return to start with #" ++ show next_ID ++ "."
103101 putStrLn "Enter a test number to perform only that test."
104102 putStrLn "q (or control-C) to quit."
105103 putStr "> "
@@ -107,102 +105,90 @@ doTestMenu nextID
107105 s <- getLine >>= return . filter (/= '\n')
108106 case s of
109107 "q" -> return mempty
110− "" -> do
111− r <- runTest $ show nextID
112− rs <- doTestMenu ( nextID + 1 )
108+ "" -> do
109+ r <- run_test $ show next_ID
110+ rs <- do_test_menu ( next_ID + 1 )
113111 return $ r : rs
114− i | isJust ( lookup i testMenu ) -> do
115− r <- runTest i
116− rs <- doTestMenu ( read i + 1 )
112+ i | isJust ( lookup i test_menu ) -> do
113+ r <- run_test i
114+ rs <- do_test_menu ( read i + 1 )
117115 return $ r : rs
118116 where
119− displayTestMenu
120− = mapM_ displayTestMenu' testMenu
121− displayTestMenu' ( i, t )
122− = putStrLn $ ( if i == show nextID
123− then "> "
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 "> "
124122 else " "
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
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
137135 putStr "\n"
138136 putStr "[Y/n] "
139137 hFlush stdout
140138 r <- getLine
141139 case r of
142− "" -> return True
140+ "" -> return True
143141 "y" -> return True
144142 "Y" -> return True
145143 "n" -> return False
146144
147145data Test = Test
148− { testName :: String
149− , testID :: String
150− , testAction :: IO ()
151− , printSummary :: IO ()
152− , confirmResults :: IO Bool
146+ { test_name :: String
147+ , test_ID :: String
148+ , test_action :: IO ()
149+ , print_summary :: IO ()
150+ , confirm_results :: IO Bool
153151 }
154152
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
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
185171 ]
186172
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
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
193179 putStrLn "Line 1"
194180 putStrLn "Line 2"
195181 putStrLn "Line 3"
196182 putStrLn "Line 4 (press return)"
197183 hFlush stdout
198184 getLine
199− releaseDisplay t
200− releaseTerminal t
185+ release_display t
186+ release_terminal t
201187 return ()
202− , printSummary = do
203− putStr $ [s|
188+ , print_summary = do
189+ putStr $ [$heredoc|
204190Once return is pressed:
205− 0. The screen will be cleared.
191+ 0. The screen will be cleared.
206192 1. Four lines of text should be visible.
207193 1. The cursor should be visible and at the start of the fifth line.
208194
@@ -210,143 +196,135 @@ After return is pressed for the second time this test then:
210196 * The screen containing the test summary should be restored;
211197 * The cursor is visible.
212198|]
213− , confirmResults = do
214− putStr $ [s|
199+ , confirm_results = do
200+ putStr $ [$heredoc|
215201Did the test output match the description?
216202|]
217− defaultSuccessConfirmResults
203+ default_success_confirm_results
218204 }
219205
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
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
231217 putStr image
232218 hFlush stdout
233219 getLine
234− releaseDisplay t
235− releaseTerminal t
220+ release_display t
221+ release_terminal t
236222 return ()
237− , printSummary = displayBoundsTestSummary True
238− , confirmResults = genericOutputMatchConfirm
223+ , print_summary = display_bounds_test_summary True
224+ , confirm_results = generic_output_match_confirm
239225 }
240226
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
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
251237 forM_ [1 .. h - 2] $ \y -> do
252− setCursorPos t 0 y
238+ set_cursor_pos t 0 y
253239 putStr "X"
254− hFlush stdout
255− setCursorPos t (w - 1) y
240+ set_cursor_pos t (w - 1) y
256241 putStr "X"
257− hFlush stdout
258− setCursorPos t 0 (h - 1)
259− let rowH = replicate (fromEnum w - 1) 'X'
260− putStr rowH
242+ set_cursor_pos t 0 (h - 1)
243+ let row_h = replicate (fromEnum w - 1) 'X'
244+ putStr row_h
261245 hFlush stdout
262246 getLine
263− releaseDisplay t
264− releaseTerminal t
247+ release_display t
248+ release_terminal t
265249 return ()
266− , printSummary = displayBoundsTestSummary True
267− , confirmResults = genericOutputMatchConfirm
250+ , print_summary = display_bounds_test_summary True
251+ , confirm_results = generic_output_match_confirm
268252 }
269253
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
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
285269 getLine
286− releaseDisplay t
287− releaseTerminal t
270+ release_display t
271+ release_terminal t
288272 return ()
289− , printSummary = displayBoundsTestSummary True
290− , confirmResults = genericOutputMatchConfirm
273+ , print_summary = display_bounds_test_summary True
274+ , confirm_results = generic_output_match_confirm
291275 }
292276
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
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
304288 forM_ [1 .. h - 2] $ \y -> do
305− setCursorPos t 0 y
289+ set_cursor_pos t 0 y
306290 putStr "X"
307− hFlush stdout
308− setCursorPos t (w - 1) y
291+ set_cursor_pos t (w - 1) y
309292 putStr "X"
310− hFlush stdout
311− setCursorPos t 0 (h - 1)
312− let rowH = row0
313− putStr rowH
293+ set_cursor_pos t 0 (h - 1)
294+ let row_h = row_0
295+ putStr row_h
314296 hFlush stdout
315297 getLine
316− showCursor t
317− releaseDisplay t
318− releaseTerminal t
298+ show_cursor t
299+ release_display t
300+ release_terminal t
319301 return ()
320− , printSummary = displayBoundsTestSummary False
321− , confirmResults = genericOutputMatchConfirm
302+ , print_summary = display_bounds_test_summary False
303+ , confirm_results = generic_output_match_confirm
322304 }
323305
324−displayBoundsTestSummary hasCursor = do
325− putStr $ [s|
306+display_bounds_test_summary has_cursor = do
307+ putStr $ [$heredoc|
326308Once return is pressed:
327309 0. The screen will be cleared.
328310|]
329− if hasCursor
311+ if has_cursor
330312 then putStr " 1. The cursor will be visible."
331313 else putStr " 1. The cursor will NOT be visible."
332− putStr [s|
333−
314+ putStr [$heredoc|
334315 2. The border of the display will be outlined in Xs.
335316 So if - and | represented the edge of the terminal window:
336317 |-------------|
337318 |XXXXXXXXXXXXX|
338319 |X X||]
339320
340− if hasCursor
341− then putStr $ [s|
342−
321+ if has_cursor
322+ then putStr $ [$heredoc|
343323 |XXXXXXXXXXXXC| |]
344− else putStr $ [s|
345−
324+ else putStr $ [$heredoc|
346325 |XXXXXXXXXXXXX| |]
347326
348− putStr $ [s|
349−
327+ putStr $ [$heredoc|
350328 |-------------|
351329
352330 ( Where C is the final position of the cursor. There may be an X drawn
@@ -358,13 +336,13 @@ After return is pressed for the second time:
358336 1. The cursor should be visible.
359337|]
360338
361−genericOutputMatchConfirm = do
362− putStr $ [s|
339+generic_output_match_confirm = do
340+ putStr $ [$heredoc|
363341Did the test output match the description?
364342|]
365− defaultSuccessConfirmResults
343+ default_success_confirm_results
366344
367−-- Explicitly define the bytes that encode each example text.
345+-- Explicitely definethe bytes that encode each example text.
368346-- This avoids any issues with how the compiler represents string literals.
369347--
370348-- This document is UTF-8 encoded so the UTF-8 string is still included for
@@ -373,24 +351,24 @@ Did the test output match the description?
373351-- It's assumed the compiler will at least not barf on UTF-8 encoded text in
374352-- comments ;-)
375353--
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
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
394372 , 8593
395373 , 8595
396374 , 8595
@@ -402,46 +380,46 @@ iso10646Txt0 = map toEnum
402380 , 65
403381 ]
404382
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)
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)
413391 hPutStr stdout "\n"
414392 hPutStr stdout "0123456789\n"
415393 hFlush stdout
416394 getLine
417− releaseDisplay t
418− releaseTerminal t
395+ release_display t
396+ release_terminal t
419397 return ()
420− , printSummary = unicodeSingleWidthSummary
421− , confirmResults = genericOutputMatchConfirm
398+ , print_summary = unicode_single_width_summary
399+ , confirm_results = generic_output_match_confirm
422400 }
423401
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
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
436414 getLine
437− releaseDisplay t
438− releaseTerminal t
415+ release_display t
416+ release_terminal t
439417 return ()
440− , printSummary = unicodeSingleWidthSummary
441− , confirmResults = genericOutputMatchConfirm
418+ , print_summary = unicode_single_width_summary
419+ , confirm_results = generic_output_match_confirm
442420 }
443421
444−unicodeSingleWidthSummary = putStr [s|
422+unicode_single_width_summary = putStr [$heredoc|
445423Once return is pressed:
446424 0. The screen will be cleared.
447425 1. The cursor will be hidden.
@@ -475,55 +453,55 @@ After return is pressed for the second time:
475453
476454-- The second example is a unicode string containing double-width glyphs
477455-- 你好吗
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)
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)
495473 hPutStr stdout "\n"
496474 hPutStr stdout "012345\n"
497475 hFlush stdout
498476 getLine
499− releaseDisplay t
500− releaseTerminal t
477+ release_display t
478+ release_terminal t
501479 return ()
502− , printSummary = unicodeDoubleWidthSummary
503− , confirmResults = genericOutputMatchConfirm
480+ , print_summary = unicode_double_width_summary
481+ , confirm_results = generic_output_match_confirm
504482 }
505483
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
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
518496 getLine
519− releaseDisplay t
520− releaseTerminal t
497+ release_display t
498+ release_terminal t
521499 return ()
522− , printSummary = unicodeDoubleWidthSummary
523− , confirmResults = genericOutputMatchConfirm
500+ , print_summary = unicode_double_width_summary
501+ , confirm_results = generic_output_match_confirm
524502 }
525503
526−unicodeDoubleWidthSummary = putStr [s|
504+unicode_double_width_summary = putStr [$heredoc|
527505Once return is pressed:
528506 0. The screen will be cleared.
529507 1. The cursor will be hidden.
@@ -550,33 +528,33 @@ After return is pressed for the second time:
550528 1. The cursor should be visible.
551529|]
552530
553−allColors = zip [ black, red, green, yellow, blue, magenta, cyan, white ]
554− [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ]
531+all_colors = zip [ black, red, green, yellow, blue, magenta, cyan, white ]
532+ [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ]
555533
556−allBrightColors
557− = zip [ brightBlack, brightRed, brightGreen, brightYellow, brightBlue, brightMagenta, brightCyan, brightWhite ]
534+all_bright_colors
535+ = zip [ bright_black, bright_red, bright_green, bright_yellow, bright_blue, bright_magenta, bright_cyan, bright_white ]
558536 [ "bright black", "bright red", "bright green", "bright yellow", "bright blue", "bright magenta", "bright cyan", "bright white" ]
559537
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
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
574552 getLine
575− releaseDisplay t
576− releaseTerminal t
553+ release_display t
554+ release_terminal t
577555 return ()
578− , printSummary = do
579− putStr $ [s|
556+ , print_summary = do
557+ putStr $ [$heredoc|
580558Once return is pressed:
581559 0. The screen will be cleared.
582560 1. The cursor will be hidden.
@@ -596,33 +574,33 @@ After return is pressed for the second time:
596574 0. The screen containing the test summary should be restored.
597575 1. The cursor should be visible.
598576|]
599− , confirmResults = do
600− putStr $ [s|
577+ , confirm_results = do
578+ putStr $ [$heredoc|
601579Did the test output match the description?
602580|]
603− defaultSuccessConfirmResults
581+ default_success_confirm_results
604582 }
605583
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
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
620598 getLine
621− releaseDisplay t
622− releaseTerminal t
599+ release_display t
600+ release_terminal t
623601 return ()
624− , printSummary = do
625− putStr $ [s|
602+ , print_summary = do
603+ putStr $ [$heredoc|
626604Once return is pressed:
627605 0. The screen will be cleared.
628606 1. The cursor will be hidden.
@@ -651,57 +629,57 @@ After return is pressed for the second time:
651629 0. The screen containing the test summary should be restored.
652630 1. The cursor should be visible.
653631|]
654− , confirmResults = do
655− putStr $ [s|
632+ , confirm_results = do
633+ putStr $ [$heredoc|
656634Did the test output match the description?
657635|]
658− defaultSuccessConfirmResults
636+ default_success_confirm_results
659637 }
660638
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
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
677655 getLine
678− releaseDisplay t
679− releaseTerminal t
656+ release_display t
657+ release_terminal t
680658 return ()
681− , printSummary = do
682− putStr $ [s|
659+ , print_summary = do
660+ putStr $ [$heredoc|
683661Once return is pressed:
684662 0. The screen will be cleared.
685663 1. The cursor will be hidden.
686664 2. 9 lines of text in three columns will be drawn:
687665 a. The first column will be a name of a standard color (for an 8 color
688− terminal) rendered with that color as the foreground color.
666+ terminal) rendered with that color as the foreground color.
689667 b. The next column will be also be the name of a standard color rendered
690668 with that color as the foreground color but the shade used should be
691− more vivid than the shade used in the first column.
669+ more vivid than the shade used in the first column.
692670 c. The final column will be the name of a color rendered with the
693671 default attributes.
694672
695673For instance, one line will be the word "magenta" and that word should be
696−rendered in the magenta color.
674+rendered in the magenta color.
697675
698676I'm not actually sure exactly what "vivid" means in this context. For xterm the
699−vivid colors are brighter.
677+vivid colors are brighter.
700678
701−Verify:
679+Verify:
702680 * The first column: The foreground color matches the named color.
703681 * The second column: The foreground color matches the named color but is
704− more vivid than the color used in the first column.
682+ more vivid than the color used in the first column.
705683 * The third column: All text is rendered with the default attributes.
706684 * The vertical bars used in each line to mark the border of a column are
707685 lined up.
@@ -710,58 +688,58 @@ After return is pressed for the second time:
710688 0. The screen containing the test summary should be restored.
711689 1. The cursor should be visible.
712690|]
713− , confirmResults = do
714− putStr $ [s|
691+ , confirm_results = do
692+ putStr $ [$heredoc|
715693Did the test output match the description?
716694|]
717− defaultSuccessConfirmResults
695+ default_success_confirm_results
718696 }
719697
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
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
736714 getLine
737− releaseDisplay t
738− releaseTerminal t
715+ release_display t
716+ release_terminal t
739717 return ()
740− , printSummary = do
741− putStr $ [s|
718+ , print_summary = do
719+ putStr $ [$heredoc|
742720Once return is pressed:
743721 0. The screen will be cleared.
744722 1. The cursor will be hidden.
745723 2. 9 lines of text in three columns will be drawn:
746724 a. The first column will contain be a name of a standard color for an 8
747725 color terminal rendered with the default foreground color with a
748− background the named color.
726+ background the named color.
749727 b. The first column will contain be a name of a standard color for an 8
750728 color terminal rendered with the default foreground color with the
751− background a vivid version of the named color.
729+ background a vivid version of the named color.
752730 c. The third column will be the name of a standard color rendered with
753731 the default attributes.
754−
732+
755733For 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.
734+be rendered in the default foreground color over a magenta background.
757735
758736I'm not actually sure exactly what "vivid" means in this context. For xterm the
759737vivid colors are brighter.
760738
761−Verify:
739+Verify:
762740 * The first column: The background color matches the named color.
763741 * The second column: The background color matches the named color and is
764− more vivid than the color used in the first column.
742+ more vivid than the color used in the first column.
765743 * The third column column: All text is rendered with the default attributes.
766744 * The vertical bars used in each line to mark the border of a column are
767745 lined up.
@@ -777,51 +755,51 @@ After return is pressed for the second time:
777755 0. The screen containing the test summary should be restored.
778756 1. The cursor should be visible.
779757|]
780− , confirmResults = do
781− putStr $ [s|
758+ , confirm_results = do
759+ putStr $ [$heredoc|
782760Did the test output match the description?
783761|]
784− defaultSuccessConfirmResults
762+ default_success_confirm_results
785763 }
786764
787−attrCombos =
765+attr_combos =
788766 [ ( "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) )
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) )
796774 ]
797775
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
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
812790 getLine
813− releaseDisplay t
814− releaseTerminal t
791+ release_display t
792+ release_terminal t
815793 return ()
816− , printSummary = do
817− putStr $ [s|
794+ , print_summary = do
795+ putStr $ [$heredoc|
818796Once return is pressed:
819797 0. The screen will be cleared.
820798 1. The cursor will be hidden.
821− 2. 8 rows of text in two columns.
799+ 2. 8 rows of text in two columns.
822800 The rows will contain the following text:
823801 default
824− bold
802+ bold
825803 blink
826804 underline
827805 bold + blink
@@ -830,8 +808,8 @@ Once return is pressed:
830808 bold + blink + underline
831809 The first column will be rendered with the described attributes. The second
832810 column will be rendered with the default attributes.
833−
834−Verify:
811+
812+Verify:
835813 * The vertical bars used in each line to mark the border of a column are
836814 lined up.
837815 * The text in the first column is rendered as described.
@@ -840,353 +818,86 @@ After return is pressed for the second time:
840818 0. The screen containing the test summary should be restored.
841819 1. The cursor should be visible.
842820|]
843− , confirmResults = do
844− putStr $ [s|
821+ , confirm_results = do
822+ putStr $ [$heredoc|
845823Did the test output match the description?
846824|]
847− defaultSuccessConfirmResults
825+ default_success_confirm_results
848826 }
849827
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
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
863841 getLine
864− releaseDisplay t
865− releaseTerminal t
842+ release_display t
843+ release_terminal t
866844 return ()
867− , printSummary = do
868− putStr $ [s|
845+ , print_summary = do
846+ putStr $ [$heredoc|
869847Once return is pressed:
870848 0. The screen will be cleared.
871849 1. The cursor will be hidden.
872850 2. A 20 character wide and 12 row high block of color squares. This should look like a palette
873851 of some sort. I'm not exactly sure if all color terminals use the same palette. I doubt it...
874852
875−Verify:
853+Verify:
876854
877855After return is pressed for the second time:
878856 0. The screen containing the test summary should be restored.
879857 1. The cursor should be visible.
880858|]
881− , confirmResults = do
882− putStr $ [s|
859+ , confirm_results = do
860+ putStr $ [$heredoc|
883861Did the test output match the description?
884862|]
885− defaultSuccessConfirmResults
863+ default_success_confirm_results
886864 }
887865
888−inlineTest0 = Test
889− { testName = "Verify styled output can be performed without clearing the screen."
890− , testID = "inlineTest0"
891− , testAction = do
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
892871 putStrLn "line 1."
893− putAttrChange_ $ backColor red >> applyStyle underline
872+ put_attr_change t $ back_color red >> apply_style underline
894873 putStrLn "line 2."
895− putAttrChange_ $ defaultAll
874+ put_attr_change t $ default_all
896875 putStrLn "line 3."
897− , printSummary = putStr $ [s|
876+ release_terminal t
877+ return ()
878+ , print_summary = putStr $ [$heredoc|
898879lines are in order.
899880The second line "line 2" should have a red background and the text underline.
900881The third line "line 3" should be drawn in the same style as the first line.
901882|]
902883
903− , confirmResults = genericOutputMatchConfirm
884+ , confirm_results = generic_output_match_confirm
904885 }
905886
906−inlineTest1 = Test
907− { testName = "Verify styled output can be performed without clearing the screen."
908− , testID = "inlineTest1"
909− , testAction = do
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
910892 putStr "Not styled. "
911− putAttrChange_ $ backColor red >> applyStyle underline
893+ put_attr_change t $ back_color red >> apply_style underline
912894 putStr " Styled! "
913− putAttrChange_ $ defaultAll
895+ put_attr_change t $ default_all
914896 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
897+ release_terminal t
947898 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.
899+ , print_summary = putStr $ [$heredoc|
954900|]
955− , confirmResults = genericOutputMatchConfirm
956− }
957901
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
902+ , confirm_results = generic_output_match_confirm
1006903 }
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−