vty-crossplatform (empty) → 0.1.0.0
raw patch · 9 files changed
+1715/−0 lines, 9 filesdep +arraydep +basedep +containers
Dependencies added: array, base, containers, mtl, random, string-qq, unknown-vty-build-platform, vty, vty-crossplatform, vty-unix, vty-windows
Files
- CHANGELOG.md +4/−0
- LICENSE +30/−0
- programs/EventEcho.hs +45/−0
- programs/ModeDemo.hs +62/−0
- programs/Rogue.hs +175/−0
- programs/interactive_terminal_test.hs +1234/−0
- src/Graphics/Vty/CrossPlatform.hs +47/−0
- src/Graphics/Vty/CrossPlatform/Testing.hs +20/−0
- vty-crossplatform.cabal +98/−0
+ CHANGELOG.md view
@@ -0,0 +1,4 @@+0.1.0.0+=======++* First version.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2023, Jonathan Daugherty++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Jonathan Daugherty nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ programs/EventEcho.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE FlexibleContexts #-}+module Main where++import qualified Graphics.Vty as V+import Graphics.Vty ((<->))+import Graphics.Vty.CrossPlatform (mkVty)++import Control.Arrow+import Control.Monad (unless)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.RWS (MonadReader(..), MonadState(..), RWST, execRWST, modify)++import Data.Sequence (Seq, (<|) )+import qualified Data.Sequence as Seq++eventBufferSize :: Int+eventBufferSize = 1000++type App = RWST V.Vty () (Seq String) IO++main :: IO ()+main = do+ vty <- mkVty V.defaultConfig+ _ <- execRWST (vtyInteract False) vty Seq.empty+ V.shutdown vty++vtyInteract :: Bool -> App ()+vtyInteract shouldExit = do+ updateDisplay+ unless shouldExit $ handleNextEvent >>= vtyInteract++updateDisplay :: App ()+updateDisplay = do+ let info = V.string V.defAttr "Press ESC to exit."+ eventLog <- foldMap (V.string V.defAttr) <$> get+ let pic = V.picForImage $ info <-> eventLog+ vty <- ask+ liftIO $ V.update vty pic++handleNextEvent :: App Bool+handleNextEvent = ask >>= liftIO . V.nextEvent >>= handleEvent+ where+ handleEvent e = do+ modify $ (<|) (show e) >>> Seq.take eventBufferSize+ return $ e == V.EvKey V.KEsc []
+ programs/ModeDemo.hs view
@@ -0,0 +1,62 @@+module Main where+++import Graphics.Vty+import Graphics.Vty.CrossPlatform (mkVty)++mkUI :: (Bool, Bool, Bool, Bool, Bool, Bool) -> Maybe Event -> Image+mkUI (m, ms, p, ps, f, fs) e =+ vertCat [ string defAttr $ "Mouse mode supported: " <> show m+ , string defAttr $ "Mouse mode status: " <> show ms+ , string defAttr " "+ , string defAttr $ "Paste mode supported: " <> show p+ , string defAttr $ "Paste mode status: " <> show ps+ , string defAttr " "+ , string defAttr $ "Focus mode supported: " <> show f+ , string defAttr $ "Focus mode status: " <> show fs+ , string defAttr " "+ , string defAttr $ "Last event: " <> show e+ , string defAttr " "+ , string defAttr "Press 'm' to toggle mouse mode, 'p' to toggle paste mode,"+ , string defAttr "'f' to toggle focus mode, and 'q' to quit."+ ]++main :: IO ()+main = do+ vty <- mkVty defaultConfig++ let renderUI lastE = do+ let output = outputIface vty+ info <- (,,,,,) <$> (pure $ supportsMode output Mouse)+ <*> getModeStatus output Mouse+ <*> (pure $ supportsMode output BracketedPaste)+ <*> getModeStatus output BracketedPaste+ <*> (pure $ supportsMode output Focus)+ <*> getModeStatus output Focus+ return $ picForImage $ mkUI info lastE++ let go lastE = do+ pic <- renderUI lastE+ update vty pic+ e <- nextEvent vty+ case e of+ EvKey (KChar 'q') [] -> return ()+ EvKey (KChar 'm') [] -> do+ let output = outputIface vty+ enabled <- getModeStatus output Mouse+ setMode output Mouse (not enabled)+ go (Just e)+ EvKey (KChar 'p') [] -> do+ let output = outputIface vty+ enabled <- getModeStatus output BracketedPaste+ setMode output BracketedPaste (not enabled)+ go (Just e)+ EvKey (KChar 'f') [] -> do+ let output = outputIface vty+ enabled <- getModeStatus output Focus+ setMode output Focus (not enabled)+ go (Just e)+ _ -> go (Just e)++ go Nothing+ shutdown vty
+ programs/Rogue.hs view
@@ -0,0 +1,175 @@+module Main where++import qualified Graphics.Vty as V+import Graphics.Vty.CrossPlatform (mkVty)++import Data.Array++import Control.Monad+import Control.Monad.RWS++import System.Random++data Player = Player+ { playerCoord :: Coord+ } deriving (Show,Eq)++data World = World+ { player :: Player+ , level :: Level+ }+ deriving (Show,Eq)++data Level = Level+ { levelStart :: Coord+ , levelEnd :: Coord+ , levelGeo :: Geo+ -- building the geo image is expensive. Cache it. Though VTY should go+ -- through greater lengths to avoid the need to cache images.+ , levelGeoImage :: V.Image+ }+ deriving (Show,Eq)++data LevelPiece+ = EmptySpace+ | Rock+ deriving (Show, Eq)++type Game = RWST V.Vty () World IO+type Geo = Array Coord LevelPiece+type Coord = (Int, Int)++main :: IO ()+main = do+ vty <- mkVty V.defaultConfig+ level0 <- mkLevel 1+ let world0 = World (Player (levelStart level0)) level0+ (_finalWorld, ()) <- execRWST play vty world0+ V.shutdown vty++-- |Generate a level randomly using the specified difficulty. Higher+-- difficulty means the level will have more rooms and cover a larger area.+mkLevel :: Int -> IO Level+mkLevel difficulty = do+ let size = 80 * difficulty+ [levelWidth, levelHeight] <- replicateM 2 $ randomRIO (size,size)+ let randomP = (,) <$> randomRIO (2, levelWidth-3) <*> randomRIO (2, levelHeight-3)+ start <- randomP+ end <- randomP+ -- first the base geography: all rocks+ let baseGeo = array ((0,0), (levelWidth-1, levelHeight-1))+ [((x,y),Rock) | x <- [0..levelWidth-1], y <- [0..levelHeight-1]]+ -- next the empty spaces that make the rooms+ -- for this we generate a number of center points+ centers <- replicateM (2 ^ difficulty + difficulty) randomP+ -- generate rooms for all those points, plus the start and end+ geo <- foldM (addRoom levelWidth levelHeight) baseGeo (start : end : centers)+ return $ Level start end geo (buildGeoImage geo)++-- |Add a room to a geography and return a new geography. Adds a+-- randomly-sized room centered at the specified coordinates.+addRoom :: Int+ -> Int+ -- ^The width and height of the geographical area+ -> Geo+ -- ^The geographical area to which a new room should be added+ -> Coord+ -- ^The desired center of the new room.+ -> IO Geo+addRoom levelWidth levelHeight geo (centerX, centerY) = do+ size <- randomRIO (5,15)+ let xMin = max 1 (centerX - size)+ xMax = min (levelWidth - 1) (centerX + size)+ yMin = max 1 (centerY - size)+ yMax = min (levelHeight - 1) (centerY + size)+ let room = [((x,y), EmptySpace) | x <- [xMin..xMax - 1], y <- [yMin..yMax - 1]]+ return (geo // room)++pieceA, dumpA :: V.Attr+pieceA = V.defAttr `V.withForeColor` V.blue `V.withBackColor` V.green+dumpA = V.defAttr `V.withStyle` V.reverseVideo++play :: Game ()+play = do+ updateDisplay+ done <- processEvent+ unless done play++processEvent :: Game Bool+processEvent = do+ k <- ask >>= liftIO . V.nextEvent+ if k == V.EvKey V.KEsc []+ then return True+ else do+ case k of+ V.EvKey (V.KChar 'r') [V.MCtrl] -> ask >>= liftIO . V.refresh+ V.EvKey V.KLeft [] -> movePlayer (-1) 0+ V.EvKey V.KRight [] -> movePlayer 1 0+ V.EvKey V.KUp [] -> movePlayer 0 (-1)+ V.EvKey V.KDown [] -> movePlayer 0 1+ _ -> return ()+ return False++movePlayer :: Int -> Int -> Game ()+movePlayer dx dy = do+ world <- get+ let Player (x, y) = player world+ let x' = x + dx+ y' = y + dy+ -- this is only valid because the level generation assures the border is+ -- always Rock+ case levelGeo (level world) ! (x',y') of+ EmptySpace -> put $ world { player = Player (x',y') }+ _ -> return ()++updateDisplay :: Game ()+updateDisplay = do+ let info = V.string V.defAttr "Move with the arrows keys. Press ESC to exit."+ -- determine offsets to place the player in the center of the level.+ (w,h) <- asks V.outputIface >>= liftIO . V.displayBounds+ thePlayer <- gets player+ let ox = (w `div` 2) - playerX thePlayer+ oy = (h `div` 2) - playerY thePlayer+ -- translate the world images to place the player in the center of the+ -- level.+ world' <- map (V.translate ox oy) <$> worldImages+ let pic = V.picForLayers $ info : world'+ vty <- ask+ liftIO $ V.update vty pic++--+-- Image-generation functions+--++worldImages :: Game [V.Image]+worldImages = do+ thePlayer <- gets player+ theLevel <- gets level+ let playerImage = V.translate (playerX thePlayer) (playerY thePlayer) (V.char pieceA '@')+ return [playerImage, levelGeoImage theLevel]++imageForGeo :: LevelPiece -> V.Image+imageForGeo EmptySpace = V.char (V.defAttr `V.withBackColor` V.green) ' '+imageForGeo Rock = V.char V.defAttr 'X'++buildGeoImage :: Geo -> V.Image+buildGeoImage geo =+ let (geoWidth, geoHeight) = snd $ bounds geo+ -- seems like a the repeated index operation should be removable. This is+ -- not performing random access but (presumably) access in order of index.+ in V.vertCat [ geoRow+ | y <- [0..geoHeight-1]+ , let geoRow = V.horizCat [ i+ | x <- [0..geoWidth-1]+ , let i = imageForGeo (geo ! (x,y))+ ]+ ]++--+-- Miscellaneous+--+playerX :: Player -> Int+playerX = fst . playerCoord++playerY :: Player -> Int+playerY = snd . playerCoord
+ programs/interactive_terminal_test.hs view
@@ -0,0 +1,1234 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Main where++import Graphics.Vty+import Graphics.Vty.CrossPlatform (mkVty)+import Graphics.Vty.CrossPlatform.Testing (mkDefaultOutput)++import Graphics.Vty.Inline++import Control.Concurrent (threadDelay)+import Control.Exception ( SomeException, catch )+import Control.Monad ( forM_, when, void )++import Data.Maybe ( isJust, fromJust )+import Data.Monoid+import Data.String.QQ ( s )+import Data.Word ( Word8 )++import Foreign.Marshal.Array ( withArrayLen )++import qualified System.Environment as Env++import System.IO ( hFlush, hPutStr, hPutBuf, stdout )++main :: IO ()+main = do+ printIntro++outputFilePath :: String+outputFilePath = "test_results.list"++printIntro :: IO ()+printIntro = do+ putStr $ [s| +This is an interactive verification program for the terminal input and output+support of the VTY library. This will ask a series of questions about what you+see on screen. The goal is to verify that VTY's output and input support+performs as expected with your terminal.++This program produces a file named + |] ++ outputFilePath ++ [s| +in the current directory that contains the results for each test assertion. This+can be used by the VTY authors to improve support for your terminal.+No personal information is contained in the report.++Each test follows, more or less, the following format:+ 0. A description of the test is printed which will include a detailed+ description of what VTY is going to try and what the expected results are.+ Press return to move on.+ 1. The program will produce some output or ask for you to press a key.+ 2. You will then be asked to confirm if the behavior matched the provided+ description. Just pressing enter implies the default response that+ everything was as expected. ++All the tests assume the following about the terminal display:+ 0. The terminal display will not be resized during a test and is at least 80 + characters in width. + 1. The terminal display is using a monospaced font for both single width and+ double width characters.+ 2. A double width character is displayed with exactly twice the width of a + single column character. This may require adjusting the font used by the+ terminal. At least, that is the case using xterm. + 3. Fonts are installed, and usable by the terminal, that define glyphs for+ a good range of the unicode characters. Each test involving unicode display+ describes the expected appearance of each glyph. ++Thanks for the help! :-D+To exit the test early enter "q" anytime at the following menu screen.++If any test fails then please post an issue to+ https://github.com/jtdaugherty/vty/issues+with the test_results.list file pasted into the issue. A suitable summary is:+"interactive terminal test failure".+|]+ waitForReturn+ results <- doTestMenu 1+ envAttributes <- mapM ( \envName -> Control.Exception.catch ( (,) envName <$> Env.getEnv envName )+ ( \ (_ :: SomeException) -> return (envName, "") )+ )+ [ "TERM", "COLORTERM", "LANG", "TERM_PROGRAM", "XTERM_VERSION" ]+ t <- mkDefaultOutput+ let resultsTxt = show envAttributes ++ "\n"+ ++ terminalID t ++ "\n"+ ++ show results ++ "\n"+ releaseTerminal t+ writeFile outputFilePath resultsTxt++waitForReturn :: IO ()+waitForReturn = do+ putStr "\n(press return to continue)"+ hFlush stdout+ void getLine++testMenu :: [(String, Test)]+testMenu = zip (map show [1:: Int ..]) allTests++doTestMenu :: Int -> IO [(String, Bool)]+doTestMenu nextID+ | nextID > length allTests = do+ putStrLn $ "Done! If there were problems, feel free to open an issue at https://github.com/jtdaugherty/vty/issues and paste the contents of the file " <> outputFilePath+ return []+ | otherwise = do+ displayTestMenu+ putStrLn $ "Press return to start with #" ++ show nextID ++ "."+ putStrLn "Enter a test number to perform only that test."+ putStrLn "q (or control-C) to quit."+ putStr "> "+ hFlush stdout+ str <- filter (/= '\n') <$> getLine+ case str of+ "q" -> return mempty+ i | isJust ( lookup i testMenu ) -> do+ r <- runTest i+ rs <- doTestMenu ( read i + 1 )+ return $ r : rs+ _ -> do+ r <- runTest $ show nextID+ rs <- doTestMenu ( nextID + 1 )+ return $ r : rs+ where+ displayTestMenu+ = mapM_ displayTestMenu' testMenu+ displayTestMenu' ( i, t )+ = putStrLn $ ( if i == show nextID+ then "> "+ else " "+ ) ++ i ++ ". " ++ testName t++runTest :: String -> IO (String, Bool)+runTest i = do+ let t = fromJust $ lookup i testMenu+ printSummary t+ waitForReturn+ testAction t+ r <- confirmResults t+ return (testID t, r)++defaultSuccessConfirmResults :: IO Bool+defaultSuccessConfirmResults = do+ putStr "\n"+ putStr "[Y/n] "+ hFlush stdout+ r <- getLine+ return $ case r of+ "" -> True+ "y" -> True+ "Y" -> True+ "n" -> False+ _ -> False++data Test = Test+ { testName :: String+ , testID :: String+ , testAction :: IO ()+ , printSummary :: IO ()+ , confirmResults :: IO Bool+ }++allTests :: [Test]+allTests+ = [ reserveOutputTest+ , displayBoundsTest0+ , displayBoundsTest1+ , displayBoundsTest2+ , displayBoundsTest3+ , unicodeSingleWidth0+ , unicodeSingleWidth1+ , unicodeDoubleWidth0+ , unicodeDoubleWidth1+ , attributesTest0+ , attributesTest1+ , attributesTest2+ , attributesTest3+ , attributesTest4+ , attributesTest5+ , inlineTest0+ , inlineTest1+ , inlineTest2+ , cursorHideTest0+ , vertCropTest0+ , vertCropTest1+ , vertCropTest2+ , vertCropTest3+ , horizCropTest0+ , horizCropTest1+ , horizCropTest2+ , horizCropTest3+ , layer0+ , layer1+ ]++reserveOutputTest :: Test+reserveOutputTest = Test+ { testName = "Initialize and reserve terminal output then restore previous state."+ , testID = "reserveOutputTest"+ , testAction = do+ t <- mkDefaultOutput+ reserveDisplay t+ putStrLn "Line 1"+ putStrLn "Line 2"+ putStrLn "Line 3"+ putStrLn "Line 4 (press return)"+ hFlush stdout+ void getLine+ releaseDisplay t+ releaseTerminal t+ return ()+ , printSummary = do+ putStr $ [s|+Once return is pressed:+ 0. The screen will be cleared.+ 1. Four lines of text should be visible.+ 1. The cursor should be visible and at the start of the fifth line.++After return is pressed for the second time this test then:+ * The screen containing the test summary should be restored;+ * The cursor is visible.+|]+ , confirmResults = do+ putStr $ [s|+Did the test output match the description?+|]+ defaultSuccessConfirmResults+ }++displayBoundsTest0 :: Test+displayBoundsTest0 = Test+ { testName = "Verify display bounds are correct test 0: Using spaces."+ , testID = "displayBoundsTest0"+ , testAction = do+ t <- mkDefaultOutput+ reserveDisplay t+ (w,h) <- displayBounds t+ let row0 = replicate (fromEnum w) 'X' ++ "\n"+ rowH = replicate (fromEnum w - 1) 'X'+ rowN = "X" ++ replicate (fromEnum w - 2) ' ' ++ "X\n"+ image = row0 ++ concat ( replicate (fromEnum h - 2) rowN) ++ rowH+ putStr image+ hFlush stdout+ void getLine+ releaseDisplay t+ releaseTerminal t+ return ()+ , printSummary = displayBoundsTestSummary True+ , confirmResults = genericOutputMatchConfirm+ }++displayBoundsTest1 :: Test+displayBoundsTest1 = Test+ { testName = "Verify display bounds are correct test 0: Using cursor movement."+ , testID = "displayBoundsTest1"+ , testAction = do+ t <- mkDefaultOutput+ reserveDisplay t+ (w,h) <- displayBounds t+ setCursorPos t 0 0+ let row0 = replicate (fromEnum w) 'X' ++ "\n"+ putStr row0+ forM_ [1 .. h - 2] $ \y -> do+ setCursorPos t 0 y+ putStr "X"+ hFlush stdout+ setCursorPos t (w - 1) y+ putStr "X"+ hFlush stdout+ setCursorPos t 0 (h - 1)+ let rowH = replicate (fromEnum w - 1) 'X'+ putStr rowH+ hFlush stdout+ void getLine+ releaseDisplay t+ releaseTerminal t+ return ()+ , printSummary = displayBoundsTestSummary True+ , confirmResults = genericOutputMatchConfirm+ }++displayBoundsTest2 :: Test+displayBoundsTest2 = Test+ { testName = "Verify display bounds are correct test 0: Using Image ops."+ , testID = "displayBoundsTest2"+ , testAction = do+ t <- mkDefaultOutput+ reserveDisplay t+ bounds@(w,h) <- displayBounds t+ let firstRow = horizCat $ replicate (fromEnum w) (char defAttr 'X')+ middleRows = vertCat $ replicate (fromEnum h - 2) middleRow+ middleRow = (char defAttr 'X') <|> backgroundFill (w - 2) 1 <|> (char defAttr 'X')+ endRow = firstRow+ image = firstRow <-> middleRows <-> endRow+ pic = (picForImage image) { picCursor = Cursor (w - 1) (h - 1) }+ d <- displayContext t bounds+ outputPicture d pic+ void getLine+ releaseDisplay t+ releaseTerminal t+ return ()+ , printSummary = displayBoundsTestSummary True+ , confirmResults = genericOutputMatchConfirm+ }++displayBoundsTest3 :: Test+displayBoundsTest3 = Test+ { testName = "Verify display bounds are correct test 0: Hide cursor; Set cursor pos."+ , testID = "displayBoundsTest3"+ , testAction = do+ t <- mkDefaultOutput+ reserveDisplay t+ (w,h) <- displayBounds t+ hideCursor t+ setCursorPos t 0 0+ let row0 = replicate (fromEnum w) 'X'+ putStrLn row0+ forM_ [1 .. h - 2] $ \y -> do+ setCursorPos t 0 y+ putStr "X"+ hFlush stdout+ setCursorPos t (w - 1) y+ putStr "X"+ hFlush stdout+ setCursorPos t 0 (h - 1)+ let rowH = row0+ putStr rowH+ hFlush stdout+ void getLine+ showCursor t+ releaseDisplay t+ releaseTerminal t+ return ()+ , printSummary = displayBoundsTestSummary False+ , confirmResults = genericOutputMatchConfirm+ }++displayBoundsTestSummary :: Bool -> IO ()+displayBoundsTestSummary hasCursor = do+ putStr $ [s|+Once return is pressed:+ 0. The screen will be cleared.+|]+ if hasCursor+ then putStr " 1. The cursor will be visible."+ else putStr " 1. The cursor will NOT be visible."+ putStr [s|++ 2. The border of the display will be outlined in Xs. + So if - and | represented the edge of the terminal window:+ |-------------|+ |XXXXXXXXXXXXX|+ |X X||]++ if hasCursor+ then putStr $ [s|++ |XXXXXXXXXXXXC| |]+ else putStr $ [s|++ |XXXXXXXXXXXXX| |]++ putStr $ [s|++ |-------------|++ ( Where C is the final position of the cursor. There may be an X drawn+ under the cursor. )+ 3. The display will remain in this state until return is pressed again.++After return is pressed for the second time:+ 0. The screen containing the test summary should be restored.+ 1. The cursor should be visible.+|]++genericOutputMatchConfirm :: IO Bool+genericOutputMatchConfirm = do+ putStr $ [s|+Did the test output match the description?+|]+ defaultSuccessConfirmResults++-- Explicitly define the bytes that encode each example text.+-- This avoids any issues with how the compiler represents string literals.+--+-- This document is UTF-8 encoded so the UTF-8 string is still included for+-- reference+--+-- It's assumed the compiler will at least not barf on UTF-8 encoded text in+-- comments ;-)+--+-- txt0 = ↑↑↓↓←→←→BA++utf8Txt0 :: [[Word8]]+utf8Txt0 = [ [ 0xe2 , 0x86 , 0x91 ]+ , [ 0xe2 , 0x86 , 0x91 ]+ , [ 0xe2 , 0x86 , 0x93 ]+ , [ 0xe2 , 0x86 , 0x93 ]+ , [ 0xe2 , 0x86 , 0x90 ]+ , [ 0xe2 , 0x86 , 0x92 ]+ , [ 0xe2 , 0x86 , 0x90 ]+ , [ 0xe2 , 0x86 , 0x92 ]+ , [ 0x42 ]+ , [ 0x41 ]+ ]++iso10646Txt0 :: String+iso10646Txt0 = map toEnum+ [ 8593+ , 8593+ , 8595+ , 8595+ , 8592+ , 8594+ , 8592+ , 8594+ , 66+ , 65+ ]++unicodeSingleWidth0 :: Test+unicodeSingleWidth0 = Test+ { testName = "Verify terminal can display unicode single-width characters. (Direct UTF-8)"+ , testID = "unicodeSingleWidth0"+ , testAction = do+ t <- mkDefaultOutput+ reserveDisplay t+ hideCursor t+ withArrayLen (concat utf8Txt0) (flip $ hPutBuf stdout)+ hPutStr stdout "\n"+ hPutStr stdout "0123456789\n"+ hFlush stdout+ void getLine+ releaseDisplay t+ releaseTerminal t+ return ()+ , printSummary = unicodeSingleWidthSummary+ , confirmResults = genericOutputMatchConfirm+ }++unicodeSingleWidth1 :: Test+unicodeSingleWidth1 = Test+ { testName = "Verify terminal can display unicode single-width characters. (Image ops)"+ , testID = "unicodeSingleWidth1"+ , testAction = do+ t <- mkDefaultOutput+ reserveDisplay t+ let pic = picForImage image+ image = line0 <-> line1+ line0 = iso10646String defAttr iso10646Txt0+ line1 = string defAttr "0123456789"+ d <- displayBounds t >>= displayContext t+ outputPicture d pic+ void getLine+ releaseDisplay t+ releaseTerminal t+ return ()+ , printSummary = unicodeSingleWidthSummary+ , confirmResults = genericOutputMatchConfirm+ }++unicodeSingleWidthSummary :: IO ()+unicodeSingleWidthSummary = putStr [s|+Once return is pressed:+ 0. The screen will be cleared.+ 1. The cursor will be hidden.+ 2. Two horizontal lines of text will be displayed:+ a. The first will be a sequence of glyphs in UTF-8 encoding. Each glyph+ will occupy one column of space. The order and appearance of the glyphs+ will be:+ | column | appearance |+ ==========================+ | 0 | up arrow |+ | 1 | up arrow |+ | 2 | down arrow |+ | 3 | down arrow |+ | 4 | left arrow |+ | 5 | right arrow |+ | 6 | left arrow |+ | 7 | right arrow |+ | 8 | B |+ | 9 | A |+ ( see: http://en.wikipedia.org/wiki/Arrow_(symbol) )+ b. The second will be: 0123456789. ++Verify: + * The far right extent of the glyphs on both lines are equal; + * The glyphs are as described.++After return is pressed for the second time:+ 0. The screen containing the test summary should be restored.+ 1. The cursor should be visible.+|]++-- The second example is a unicode string containing double-width glyphs+-- 你好吗+utf8Txt1 :: [[Word8]]+utf8Txt1 = [ [0xe4,0xbd,0xa0]+ , [0xe5,0xa5,0xbd]+ , [0xe5,0x90,0x97]+ ]++iso10646Txt1 :: String+iso10646Txt1 = map toEnum [20320,22909,21527]++unicodeDoubleWidth0 :: Test+unicodeDoubleWidth0 = Test+ { testName = "Verify terminal can display unicode double-width characters. (Direct UTF-8)"+ , testID = "unicodeDoubleWidth0"+ , testAction = do+ t <- mkDefaultOutput+ reserveDisplay t+ hideCursor t+ withArrayLen (concat utf8Txt1) (flip $ hPutBuf stdout)+ hPutStr stdout "\n"+ hPutStr stdout "012345\n"+ hFlush stdout+ void getLine+ releaseDisplay t+ releaseTerminal t+ return ()+ , printSummary = unicodeDoubleWidthSummary+ , confirmResults = genericOutputMatchConfirm+ }++unicodeDoubleWidth1 :: Test+unicodeDoubleWidth1 = Test+ { testName = "Verify terminal can display unicode double-width characters. (Image ops)"+ , testID = "unicodeDoubleWidth1"+ , testAction = do+ t <- mkDefaultOutput+ reserveDisplay t+ let pic = picForImage image+ image = line0 <-> line1+ line0 = iso10646String defAttr iso10646Txt1+ line1 = string defAttr "012345"+ d <- displayBounds t >>= displayContext t+ outputPicture d pic+ void getLine+ releaseDisplay t+ releaseTerminal t+ return ()+ , printSummary = unicodeDoubleWidthSummary+ , confirmResults = genericOutputMatchConfirm+ }++unicodeDoubleWidthSummary :: IO ()+unicodeDoubleWidthSummary = putStr [s|+Once return is pressed:+ 0. The screen will be cleared.+ 1. The cursor will be hidden.+ 2. Two horizontal lines of text will be displayed:+ a. The first will be a sequence of glyphs in UTF-8 encoding. Each glyph+ will occupy two columns of space. The order and appearance of the glyphs+ will be:+ | column | appearance |+ ======================================+ | 0 | first half of ni3 |+ | 1 | second half of ni3 |+ | 2 | first half of hao3 |+ | 3 | second half of hao3 |+ | 4 | first half of ma |+ | 5 | second half of ma |+ b. The second will be: 012345. ++Verify: + * The far right extent of the glyphs on both lines are equal; + * The glyphs are as described.++After return is pressed for the second time:+ 0. The screen containing the test summary should be restored.+ 1. The cursor should be visible.+|]++allColors :: [(Color, String)]+allColors = zip [ black, red, green, yellow, blue, magenta, cyan, white ]+ [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ]++allBrightColors :: [(Color, String)]+allBrightColors+ = zip [ brightBlack, brightRed, brightGreen, brightYellow, brightBlue, brightMagenta, brightCyan, brightWhite ]+ [ "bright black", "bright red", "bright green", "bright yellow", "bright blue", "bright magenta", "bright cyan", "bright white" ]++attributesTest0 :: Test+attributesTest0 = Test+ { testName = "Character attributes: foreground colors."+ , testID = "attributesTest0"+ , testAction = do+ t <- mkDefaultOutput+ reserveDisplay t+ let pic = picForImage image+ image = border <|> column0 <|> border <|> column1 <|> border+ column0 = vertCat $ map lineWithColor allColors+ border = vertCat $ replicate (length allColors) $ string defAttr " | "+ column1 = vertCat $ map (string defAttr . snd) allColors+ lineWithColor (c, cName) = string (defAttr `withForeColor` c) cName+ d <- displayBounds t >>= displayContext t+ outputPicture d pic+ void getLine+ releaseDisplay t+ releaseTerminal t+ return ()+ , printSummary = do+ putStr $ [s|+Once return is pressed:+ 0. The screen will be cleared.+ 1. The cursor will be hidden.+ 2. 9 lines of text in two columns will be drawn. The first column will be a+ name of a standard color (for an 8 color terminal) rendered in that color.+ For instance, one line will be the word "magenta" and that word should be+ rendered in the magenta color. The second column will be the name of a+ standard color rendered with the default attributes.++Verify: + * In the first column: The foreground color matches the named color.+ * The second column: All text is rendered with the default attributes.+ * The vertical bars used in each line to mark the border of a column are+ lined up.++After return is pressed for the second time:+ 0. The screen containing the test summary should be restored.+ 1. The cursor should be visible.+|]+ , confirmResults = do+ putStr $ [s|+Did the test output match the description?+|]+ defaultSuccessConfirmResults+ }++attributesTest1 :: Test+attributesTest1 = Test+ { testName = "Character attributes: background colors."+ , testID = "attributesTest1"+ , testAction = do+ t <- mkDefaultOutput+ reserveDisplay t+ let pic = picForImage image+ image = border <|> column0 <|> border <|> column1 <|> border+ column0 = vertCat $ map lineWithColor allColors+ border = vertCat $ replicate (length allColors) $ string defAttr " | "+ column1 = vertCat $ map (string defAttr . snd) allColors+ lineWithColor (c, cName) = string (defAttr `withBackColor` c) cName+ d <- displayBounds t >>= displayContext t+ outputPicture d pic+ void getLine+ releaseDisplay t+ releaseTerminal t+ return ()+ , printSummary = do+ putStr $ [s|+Once return is pressed:+ 0. The screen will be cleared.+ 1. The cursor will be hidden.+ 2. 9 lines of text in two columns will be drawn. The first column will+ contain be a name of a standard color for an 8 color terminal rendered with+ the default foreground color with a background the named color. For+ instance, one line will contain be the word "magenta" and the word should+ be rendered in the default foreground color over a magenta background. The+ second column will be the name of a standard color rendered with the default+ attributes.++Verify: + * The first column: The background color matches the named color.+ * The second column: All text is rendered with the default attributes.+ * The vertical bars used in each line to mark the border of a column are+ lined up.++Note: I haven't decided if, in this case, the background color should extend to+fills added for alignment. Right now the selected background color is only+applied to the background where the word is actually rendered. Since each word+is not of the same length VTY adds background fills to make the width of each+row effectively the same. These added fills are all currently rendered with the+default background pattern.++After return is pressed for the second time:+ 0. The screen containing the test summary should be restored.+ 1. The cursor should be visible.+|]+ , confirmResults = do+ putStr $ [s|+Did the test output match the description?+|]+ defaultSuccessConfirmResults+ }++attributesTest2 :: Test+attributesTest2 = Test+ { testName = "Character attributes: Vivid foreground colors."+ , testID = "attributesTest2"+ , testAction = do+ t <- mkDefaultOutput+ reserveDisplay t+ let pic = picForImage image+ image = horizCat [border, column0, border, column1, border, column2, border]+ border = vertCat $ replicate (length allColors) $ string defAttr " | "+ column0 = vertCat $ map lineWithColor0 allColors+ column1 = vertCat $ map lineWithColor1 allBrightColors+ column2 = vertCat $ map (string defAttr . snd) allColors+ lineWithColor0 (c, cName) = string (defAttr `withForeColor` c) cName+ lineWithColor1 (c, cName) = string (defAttr `withForeColor` c) cName+ d <- displayBounds t >>= displayContext t+ outputPicture d pic+ void getLine+ releaseDisplay t+ releaseTerminal t+ return ()+ , printSummary = do+ putStr $ [s|+Once return is pressed:+ 0. The screen will be cleared.+ 1. The cursor will be hidden.+ 2. 9 lines of text in three columns will be drawn:+ a. The first column will be a name of a standard color (for an 8 color+ terminal) rendered with that color as the foreground color.+ b. The next column will be also be the name of a standard color rendered+ with that color as the foreground color but the shade used should be+ more vivid than the shade used in the first column.+ c. The final column will be the name of a color rendered with the+ default attributes.++For instance, one line will be the word "magenta" and that word should be+rendered in the magenta color.++I'm not actually sure exactly what "vivid" means in this context. For xterm the+vivid colors are brighter.++Verify:+ * The first column: The foreground color matches the named color.+ * The second column: The foreground color matches the named color but is+ more vivid than the color used in the first column.+ * The third column: All text is rendered with the default attributes.+ * The vertical bars used in each line to mark the border of a column are+ lined up.++After return is pressed for the second time:+ 0. The screen containing the test summary should be restored.+ 1. The cursor should be visible.+|]+ , confirmResults = do+ putStr $ [s|+Did the test output match the description?+|]+ defaultSuccessConfirmResults+ }++attributesTest3 :: Test+attributesTest3 = Test+ { testName = "Character attributes: Vivid background colors."+ , testID = "attributesTest3"+ , testAction = do+ t <- mkDefaultOutput+ reserveDisplay t+ let pic = picForImage image+ image = horizCat [border, column0, border, column1, border, column2, border]+ border = vertCat $ replicate (length allColors) $ string defAttr " | "+ column0 = vertCat $ map lineWithColor0 allColors+ column1 = vertCat $ map lineWithColor1 allBrightColors+ column2 = vertCat $ map (string defAttr . snd) allColors+ lineWithColor0 (c, cName) = string (defAttr `withBackColor` c) cName+ lineWithColor1 (c, cName) = string (defAttr `withBackColor` c) cName+ d <- displayBounds t >>= displayContext t+ outputPicture d pic+ void getLine+ releaseDisplay t+ releaseTerminal t+ return ()+ , printSummary = do+ putStr $ [s|+Once return is pressed:+ 0. The screen will be cleared.+ 1. The cursor will be hidden.+ 2. 9 lines of text in three columns will be drawn:+ a. The first column will contain be a name of a standard color for an 8+ color terminal rendered with the default foreground color with a+ background the named color.+ b. The first column will contain be a name of a standard color for an 8+ color terminal rendered with the default foreground color with the+ background a vivid version of the named color.+ c. The third column will be the name of a standard color rendered with+ the default attributes.++For instance, one line will contain be the word "magenta" and the word should+be rendered in the default foreground color over a magenta background.++I'm not actually sure exactly what "vivid" means in this context. For xterm the+vivid colors are brighter.++Verify:+ * The first column: The background color matches the named color.+ * The second column: The background color matches the named color and is+ more vivid than the color used in the first column.+ * The third column column: All text is rendered with the default attributes.+ * The vertical bars used in each line to mark the border of a column are+ lined up.++Note: I haven't decided if, in this case, the background color should extend to+fills added for alignment. Right now the selected background color is only+applied to the background where the word is actually rendered. Since each word+is not of the same length VTY adds background fills to make the width of each+row effectively the same. These added fills are all currently rendered with the+default background pattern.++After return is pressed for the second time:+ 0. The screen containing the test summary should be restored.+ 1. The cursor should be visible.+|]+ , confirmResults = do+ putStr $ [s|+Did the test output match the description?+|]+ defaultSuccessConfirmResults+ }++attrCombos :: [(String, Attr -> Attr)]+attrCombos =+ [ ( "default", id )+ , ( "bold", flip withStyle bold )+ , ( "blink", flip withStyle blink )+ , ( "underline", flip withStyle underline )+ , ( "bold + blink", flip withStyle (bold + blink) )+ , ( "bold + underline", flip withStyle (bold + underline) )+ , ( "underline + blink", flip withStyle (underline + blink) )+ , ( "bold + blink + underline", flip withStyle (bold + blink + underline) )+ ]++attributesTest4 :: Test+attributesTest4 = Test+ { testName = "Character attributes: Bold; Blink; Underline."+ , testID = "attributesTest4"+ , testAction = do+ t <- mkDefaultOutput+ reserveDisplay t+ let pic = picForImage image+ image = horizCat [border, column0, border, column1, border]+ border = vertCat $ replicate (length attrCombos) $ string defAttr " | "+ column0 = vertCat $ map lineWithAttrs attrCombos+ column1 = vertCat $ map (string defAttr . fst) attrCombos+ lineWithAttrs (desc, attrF) = string (attrF defAttr) desc+ d <- displayBounds t >>= displayContext t+ outputPicture d pic+ void getLine+ releaseDisplay t+ releaseTerminal t+ return ()+ , printSummary = do+ putStr $ [s|+Once return is pressed:+ 0. The screen will be cleared.+ 1. The cursor will be hidden.+ 2. 8 rows of text in two columns.+ The rows will contain the following text:+ default+ bold+ blink+ underline+ bold + blink+ bold + underline+ underline + blink+ bold + blink + underline+ The first column will be rendered with the described attributes. The second+ column will be rendered with the default attributes.++Verify:+ * The vertical bars used in each line to mark the border of a column are+ lined up.+ * The text in the first column is rendered as described.++After return is pressed for the second time:+ 0. The screen containing the test summary should be restored.+ 1. The cursor should be visible.+|]+ , confirmResults = do+ putStr $ [s|+Did the test output match the description?+|]+ defaultSuccessConfirmResults+ }++attributesTest5 :: Test+attributesTest5 = Test+ { testName = "Character attributes: 240 color palette"+ , testID = "attributesTest5"+ , testAction = do+ t <- mkDefaultOutput+ reserveDisplay t+ let pic = picForImage image+ image = vertCat $ map horizCat $ splitColorImages colorImages+ colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]+ splitColorImages [] = []+ splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))+ d <- displayBounds t >>= displayContext t+ outputPicture d pic+ void getLine+ releaseDisplay t+ releaseTerminal t+ return ()+ , printSummary = do+ putStr $ [s|+Once return is pressed:+ 0. The screen will be cleared.+ 1. The cursor will be hidden.+ 2. A 20 character wide and 12 row high block of color squares. This should look like a palette+ of some sort. I'm not exactly sure if all color terminals use the same palette. I doubt it...++Verify:++After return is pressed for the second time:+ 0. The screen containing the test summary should be restored.+ 1. The cursor should be visible.+|]+ , confirmResults = do+ putStr $ [s|+Did the test output match the description?+|]+ defaultSuccessConfirmResults+ }++inlineTest0 :: Test+inlineTest0 = Test+ { testName = "Verify styled output can be performed without clearing the screen."+ , testID = "inlineTest0"+ , testAction = do+ t <- mkDefaultOutput+ putStrLn "line 1."+ putAttrChange_ t $ backColor red >> applyStyle underline+ putStrLn "line 2."+ putAttrChange_ t $ defaultAll+ putStrLn "line 3."+ , printSummary = putStr $ [s|+lines are in order.+The second line "line 2" should have a red background and the text underline.+The third line "line 3" should be drawn in the same style as the first line.+|]++ , confirmResults = genericOutputMatchConfirm+ }++inlineTest1 :: Test+inlineTest1 = Test+ { testName = "Verify styled output can be performed without clearing the screen."+ , testID = "inlineTest1"+ , testAction = do+ t <- mkDefaultOutput+ putStr "Not styled. "+ putAttrChange_ t $ backColor red >> applyStyle underline+ putStr " Styled! "+ putAttrChange_ t $ defaultAll+ putStrLn "Not styled."+ , printSummary = putStr $ [s|+|]++ , confirmResults = genericOutputMatchConfirm+ }++inlineTest2 :: Test+inlineTest2 = Test+ { testName = "Verify styled output can be performed without clearing the screen."+ , testID = "inlineTest2"+ , testAction = do+ t <- mkDefaultOutput+ putStr "Not styled. "+ putAttrChange_ t $ backColor red >> applyStyle underline+ putStr " Styled! "+ putAttrChange_ t $ defaultAll+ putStr "Not styled.\n"+ , printSummary = putStr $ [s|+|]+ , confirmResults = genericOutputMatchConfirm+ }++cursorHideTest0 :: Test+cursorHideTest0 = Test+ { testName = "Verify the cursor is hid and re-shown. issue #7"+ , testID = "cursorHideTest0"+ , testAction = do+ vty <- mkVty defaultConfig+ showCursor $ outputIface vty+ setCursorPos (outputIface vty) 5 5+ whileM (isResize <$> nextEvent vty)+ hideCursor $ outputIface vty+ void $ nextEvent vty+ shutdown vty+ return ()+ , printSummary = putStr $ [s|+ 1. verify the cursor is displayed.+ 2. press enter+ 3. verify the cursor is hid.+ 4. press enter.+ 5. the display should return to the state before the test.+|]+ , confirmResults = genericOutputMatchConfirm+ }++outputImageAndWait :: Image -> IO ()+outputImageAndWait image = do+ let pic = picForImage image+ outputPicAndWait pic++outputPicAndWait :: Picture -> IO ()+outputPicAndWait pic = do+ t <- mkDefaultOutput+ reserveDisplay t+ d <- displayBounds t >>= displayContext t+ outputPicture d pic+ void getLine+ releaseDisplay t+ releaseTerminal t+ return ()++vertCropTest0 :: Test+vertCropTest0 = Test+ { testName = "Verify bottom cropping works as expected with single column chars"+ , testID = "vertCropTest0"+ , testAction = do+ let block0 = cropBottom 2 $ vertCat $ map (string defAttr) lorumIpsum+ block1 = vertCat $ map (string defAttr) $ take 2 lorumIpsum+ image = block0 <-> backgroundFill 10 2 <-> block1+ outputImageAndWait image+ , printSummary = putStr $ [s|+ 1. Verify the two text blocks are identical.+ 2. press enter.+ 3. the display should return to the state before the test.+|]+ , confirmResults = genericOutputMatchConfirm+ }++vertCropTest1 :: Test+vertCropTest1 = Test+ { testName = "Verify bottom cropping works as expected with double column chars"+ , testID = "vertCropTest1"+ , testAction = do+ let block0 = cropBottom 2 $ vertCat $ map (string defAttr) lorumIpsumChinese+ block1 = vertCat $ map (string defAttr) $ take 2 lorumIpsumChinese+ image = block0 <-> backgroundFill 10 2 <-> block1+ outputImageAndWait image+ , printSummary = putStr $ [s|+ 1. Verify the two text blocks are identical.+ 2. press enter.+ 3. the display should return to the state before the test.+|]+ , confirmResults = genericOutputMatchConfirm+ }++vertCropTest2 :: Test+vertCropTest2 = Test+ { testName = "Verify top cropping works as expected with single column chars"+ , testID = "vertCropTest2"+ , testAction = do+ let block0 = cropTop 2 $ vertCat $ map (string defAttr) lorumIpsum+ block1 = vertCat $ map (string defAttr) $ drop (length lorumIpsum - 2) lorumIpsum+ image = block0 <-> backgroundFill 10 2 <-> block1+ outputImageAndWait image+ , printSummary = putStr $ [s|+ 1. Verify the two text blocks are identical.+ 2. press enter.+ 3. the display should return to the state before the test.+|]+ , confirmResults = genericOutputMatchConfirm+ }++vertCropTest3 :: Test+vertCropTest3 = Test+ { testName = "Verify top cropping works as expected with double column chars"+ , testID = "vertCropTest3"+ , testAction = do+ let block0 = cropTop 2 $ vertCat $ map (string defAttr) lorumIpsumChinese+ block1 = vertCat $ map (string defAttr) $ drop (length lorumIpsumChinese - 2 ) lorumIpsumChinese+ image = block0 <-> backgroundFill 10 2 <-> block1+ outputImageAndWait image+ , printSummary = putStr $ [s|+ 1. Verify the two text blocks are identical.+ 2. press enter.+ 3. the display should return to the state before the test.+|]+ , confirmResults = genericOutputMatchConfirm+ }++horizCropTest0 :: Test+horizCropTest0 = Test+ { testName = "Verify right cropping works as expected with single column chars"+ , testID = "horizCropTest0"+ , testAction = do+ let baseImage = vertCat $ map (string defAttr) lorumIpsum+ croppedImage = cropRight (imageWidth baseImage `div` 2) baseImage+ image = baseImage <-> backgroundFill 10 2 <-> croppedImage+ outputImageAndWait image+ , printSummary = putStr $ [s|+ 1. Verify the bottom text block is about half the width of the top text block.+ 2. press enter.+ 3. the display should return to the state before the test.+|]+ , confirmResults = genericOutputMatchConfirm+ }++horizCropTest1 :: Test+horizCropTest1 = Test+ { testName = "Verify right cropping works as expected with double column chars"+ , testID = "horizCropTest1"+ , testAction = do+ let baseImage = vertCat $ map (string defAttr) lorumIpsumChinese+ croppedImage = cropRight (imageWidth baseImage `div` 2) baseImage+ image = baseImage <-> backgroundFill 10 2 <-> croppedImage+ outputImageAndWait image+ , printSummary = putStr $ [s|+ 1. Verify the bottom text block is the left half of the top block. Ellipses on the right edge are OK.+ 2. press enter.+ 3. the display should return to the state before the test.+|]+ , confirmResults = genericOutputMatchConfirm+ }++horizCropTest2 :: Test+horizCropTest2 = Test+ { testName = "Verify left cropping works as expected with single column chars"+ , testID = "horizCropTest2"+ , testAction = do+ let baseImage = vertCat $ map (string defAttr) lorumIpsum+ croppedImage = cropLeft (imageWidth baseImage `div` 2) baseImage+ image = baseImage <-> backgroundFill 10 2 <-> croppedImage+ outputImageAndWait image+ , printSummary = putStr $ [s|+ 1. Verify the bottom text block is the right half of the top text block.+ 2. press enter.+ 3. the display should return to the state before the test.+|]+ , confirmResults = genericOutputMatchConfirm+ }++horizCropTest3 :: Test+horizCropTest3 = Test+ { testName = "Verify right cropping works as expected with double column chars"+ , testID = "horizCropTest3"+ , testAction = do+ let baseImage = vertCat $ map (string defAttr) lorumIpsumChinese+ croppedImage = cropLeft (imageWidth baseImage `div` 2) baseImage+ image = baseImage <-> backgroundFill 10 2 <-> croppedImage+ outputImageAndWait image+ , printSummary = putStr $ [s|+ 1. Verify the bottom text block is the right half of the top block. Ellipses on the left edge are OK.+ 2. press enter.+ 3. the display should return to the state before the test.+|]+ , confirmResults = genericOutputMatchConfirm+ }++layer0 :: Test+layer0 = Test+ { testName = "verify layer 0"+ , testID = "layer0"+ , testAction = do+ let upperImage = vertCat $ map (string defAttr) lorumIpsumChinese+ lowerImage = vertCat $ map (string defAttr) lorumIpsum+ p = picForLayers [upperImage, lowerImage]+ outputPicAndWait p+ , printSummary = putStr $ [s|+ 1. Verify the text block appears to be Chinese text placed on top Latin text.+ 2. press enter.+ 3. the display should return to the state before the test.+|]+ , confirmResults = genericOutputMatchConfirm+ }++layer1 :: Test+layer1 = Test+ { testName = "verify layer 1"+ , testID = "layer1"+ , testAction = do+ let upperImage = vertCat $ map (string defAttr) lorumIpsumChinese+ block = resize 10 10 upperImage+ l0 = vertCat $ map (string defAttr) lorumIpsum+ l1 = charFill (defAttr `withBackColor` blue) '#' (1000::Int) 1000+ cheesyAnim0 block [l0, l1]+ , printSummary = putStr $ [s|+ 1. Verify the text block appears to be Chinese text moving on top a Latin text.+ Which is all on a background of '#' characters over blue.+ 2. press enter.+ 3. the display should return to the state before the test.+|]+ , confirmResults = genericOutputMatchConfirm+ }++cheesyAnim0 :: Image -> [Image] -> IO ()+cheesyAnim0 i background = do+ t <- mkDefaultOutput+ reserveDisplay t+ bounds <- displayBounds t+ d <- displayContext t bounds+ forM_ [(0::Int)..2] $ \_ -> do+ forM_ [0..100] $ \tick -> do+ let i_offset = translate (tick `mod` fst bounds)+ (tick `div` 2 `mod` snd bounds)+ i+ let pic = picForLayers $ i_offset : background+ outputPicture d pic+ threadDelay 50000+ forM_ [0..100] $ \tick -> do+ let i_offset = translate (tick * (-1) `mod` fst bounds)+ (tick * (-1) `div` 2 `mod` snd bounds)+ i+ let pic = picForLayers $ i_offset : background+ outputPicture d pic+ threadDelay 50000+ releaseDisplay t+ releaseTerminal t+ return ()++lorumIpsum :: [String]+lorumIpsum = lines [s|+Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium,+totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae+dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit,+sed quia consequuntur magni dolores eos qui ratione voluptatem sequi nesciunt. Neque porro quisquam+est, qui dolorem ipsum quia dolor sit amet, consectetur, adipisci velit, sed quia non numquam eius+modi tempora incidunt ut labore et dolore magnam aliquam quaerat voluptatem. Ut enim ad minima+veniam, quis nostrum exercitationem ullam corporis suscipit laboriosam, nisi ut aliquid ex ea+commodi consequatur? Quis autem vel eum iure reprehenderit qui in ea voluptate velit esse quam nihil+molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?+|]++lorumIpsumChinese :: [String]+lorumIpsumChinese = lines [s|+輐銛 螷蟞覮 裌覅詵 暕 鴅噮 槶 惝掭掝 婸媥媕 耏胠臿, 汫汭沎 忕汌卣 蚡袀 僣 蒮 瀁瀎瀊 渮湸湤 緌翢,+腠腶舝 糲蘥蠩 樏殣氀 蒮 蹢鎒 滍 鸄齴 櫧櫋瀩 鬄鵊鵙 莃荶衒, 毸溠 橀 簎艜薤 莃荶衒 翣聜蒢+斔櫅檷 晛桼桾 拻敁柧 犿玒 膣, 墐 笓粊紒 bacon 鼀齕, 蔝蓶蓨 顊顃餭 姴怤 骱 暕 蹢鎒鎛 藒襓謥 鄻鎟霣+鬎鯪, 鐩闤 硻禂稢 谾踘遳 撱 赲 迡 箷 蛃袚觙 萇雊蜩 壿嫷 鋡 縢羱聬 跐鉠鉣 蔝蓶蓨 匢奾灱 溮煡煟 雥齆犪+蔰 虈觿, 腷腯葹 鍹餳駷 蛚袲褁蜸 皯竻 瀁瀎 蜭蜸覟 梪涫湴 揗斝湁 毼+|]++isResize :: Event -> Bool+isResize (EvResize _ _) = True+isResize _ = False++whileM :: Monad m => m Bool -> m ()+whileM m = do+ tst <- m+ when tst $ whileM m
+ src/Graphics/Vty/CrossPlatform.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE CPP #-}+-- | This module exposes a simple API to initialize Vty in a+-- platform-independent way. This module only provides @mkVty@+-- for initializing the terminal. The rest of the Vty API is+-- accessed through the @vty@ package's API. If you need access to+-- platform-specific settings, it might be best to depend on and use the+-- platform-specific packages directly instead of using this package.+module Graphics.Vty.CrossPlatform+ ( mkVty+ )+where++import Graphics.Vty (Vty)+import Graphics.Vty.Config (VtyUserConfig)++-- Import the platform-specific module that provides 'mkVty'. The+-- convention is that each platform package should export a 'mkVty' with+-- the type signature indicated below, so only branching at import time+-- like this ensures that the build will break if either 1) a platform+-- doesn't provide 'mkVty' or 2) provides it but at a different type.+--+-- This approach works fine for now with just two main platforms as+-- options, but if we need to support a third, we'll probably need to+-- make this check more sophisticated. This approach also has a slight+-- risk in that it may come to a different conclusion about the build+-- platform than the Cabal "if os(...)" check. We could avoid that+-- by using the Cabal API here to do OS detection, but that has the+-- drawback that we'd then be depending on the Cabal library, and that+-- gets to be a big pain when the version of Cabal we depend on happens+-- to be different than the one used to build the 'cabal-install' that+-- got used to do the build.+#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+import qualified Graphics.Vty.Platform.Windows as Platform+#else+import qualified Graphics.Vty.Platform.Unix as Platform+#endif++-- | Build a 'Vty' handle with the specified configuration.+--+-- This dispatches to the appropriate platform-specific implementation+-- at build time based on the build environment's operating system.+mkVty :: VtyUserConfig+ -- ^ The configuration to use, usually+ -- 'Graphics.Vty.Config.defaultConfig' or the result of+ -- 'Graphics.Vty.Config.userConfig'.+ -> IO Vty+mkVty = Platform.mkVty
+ src/Graphics/Vty/CrossPlatform/Testing.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE CPP #-}+module Graphics.Vty.CrossPlatform.Testing+ ( mkDefaultOutput+ )+where++import Graphics.Vty (Output)++#if defined(mingw32_HOST_OS) || defined(__MINGW32__)+import Graphics.Vty.Platform.Windows.Output (buildOutput)+import Graphics.Vty.Platform.Windows.Settings (defaultSettings)+#else+import Graphics.Vty.Platform.Unix.Output (buildOutput)+import Graphics.Vty.Platform.Unix.Settings (defaultSettings)+#endif++-- | This helper is not intended for end-user consumption; it is exposed+-- only for testing purposes.+mkDefaultOutput :: IO Output+mkDefaultOutput = defaultSettings >>= buildOutput
+ vty-crossplatform.cabal view
@@ -0,0 +1,98 @@+cabal-version: 3.0+name: vty-crossplatform+version: 0.1.0.0+synopsis: Cross-platform support for Vty+description: This package provides a generic interface for multiple+ Vty platforms in one package so you don't have to+ conditionally depend on them in your cabal file.+license: BSD-3-Clause+license-file: LICENSE+author: Jonathan Daugherty+maintainer: cygnus@foobox.com+copyright: (c) 2023 Jonathan Daugherty+category: Graphics+build-type: Simple+extra-doc-files: CHANGELOG.md++common warnings+ ghc-options: -Wall++Flag demos+ Description: Build demonstration programs+ Default: False++library+ import: warnings+ hs-source-dirs: src+ default-language: Haskell2010+ exposed-modules: Graphics.Vty.CrossPlatform+ , Graphics.Vty.CrossPlatform.Testing+ build-depends: base >= 4.8 && < 5,+ vty >= 6.0++ if os(darwin)+ build-depends: vty-unix+ elif os(linux)+ build-depends: vty-unix+ elif os(windows)+ build-depends: vty-windows+ else+ build-depends: unknown-vty-build-platform++executable vty-rogue-demo+ if !flag(demos)+ Buildable: False++ hs-source-dirs: programs+ ghc-options: -threaded -Wall -Wcompat -O2+ default-language: Haskell2010+ default-extensions: CPP+ main-is: Rogue.hs+ build-depends: base,+ vty,+ vty-crossplatform,+ random,+ mtl,+ array++executable vty-event-echo+ if !flag(demos)+ Buildable: False++ hs-source-dirs: programs+ ghc-options: -threaded -Wall -Wcompat -O2+ default-language: Haskell2010+ default-extensions: CPP+ main-is: EventEcho.hs+ build-depends: base,+ vty,+ vty-crossplatform,+ containers,+ mtl++executable vty-mode-demo+ if !flag(demos)+ Buildable: False++ hs-source-dirs: programs+ ghc-options: -threaded -Wall -Wcompat -O2+ default-language: Haskell2010+ default-extensions: CPP+ main-is: ModeDemo.hs+ build-depends: base,+ vty,+ vty-crossplatform++executable vty-interactive-terminal-test+ if !flag(demos)+ Buildable: False++ hs-source-dirs: programs+ ghc-options: -threaded -Wall -Wcompat -O2+ default-language: Haskell2010+ default-extensions: CPP+ main-is: interactive_terminal_test.hs+ build-depends: base,+ string-qq,+ vty,+ vty-crossplatform