vty-crossplatform-0.4.0.0/0000755000000000000000000000000007346545000013560 5ustar0000000000000000vty-crossplatform-0.4.0.0/CHANGELOG.md0000644000000000000000000000056207346545000015374 0ustar00000000000000000.4.0.0 ======= * Updated to work with `vty-windows` 0.2.0.0. 0.3.0.0 ======= Package changes: * Updated `vty` lower bound to 6.1. Updated testing code to build with 6.1. 0.2.0.0 ======= Package changes: * Added build-time selection of `vty-unix` on FreeBSD, OpenBSD, NetBSD, Solaris, AIX, HPUX, IRIX, Hurd, and DragonflyBSD. 0.1.0.0 ======= * First version. vty-crossplatform-0.4.0.0/LICENSE0000644000000000000000000000277607346545000014601 0ustar0000000000000000Copyright (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. vty-crossplatform-0.4.0.0/programs/0000755000000000000000000000000007346545000015412 5ustar0000000000000000vty-crossplatform-0.4.0.0/programs/EventEcho.hs0000644000000000000000000000233307346545000017627 0ustar0000000000000000{-# 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 [] vty-crossplatform-0.4.0.0/programs/ModeDemo.hs0000644000000000000000000000457107346545000017446 0ustar0000000000000000module 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 vty-crossplatform-0.4.0.0/programs/Rogue.hs0000644000000000000000000001320507346545000017030 0ustar0000000000000000module 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 vty-crossplatform-0.4.0.0/programs/interactive_terminal_test.hs0000644000000000000000000012621507346545000023224 0ustar0000000000000000{-# 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 vty-crossplatform-0.4.0.0/src/Graphics/Vty/0000755000000000000000000000000007346545000016671 5ustar0000000000000000vty-crossplatform-0.4.0.0/src/Graphics/Vty/CrossPlatform.hs0000644000000000000000000000414507346545000022027 0ustar0000000000000000{-# 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 vty-crossplatform-0.4.0.0/src/Graphics/Vty/CrossPlatform/0000755000000000000000000000000007346545000021467 5ustar0000000000000000vty-crossplatform-0.4.0.0/src/Graphics/Vty/CrossPlatform/Testing.hs0000644000000000000000000000123507346545000023441 0ustar0000000000000000{-# LANGUAGE CPP #-} module Graphics.Vty.CrossPlatform.Testing ( mkDefaultOutput ) where import Graphics.Vty (Output) import Graphics.Vty.Config (defaultConfig) #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 defaultConfig vty-crossplatform-0.4.0.0/vty-crossplatform.cabal0000644000000000000000000000614407346545000020267 0ustar0000000000000000cabal-version: 3.0 name: vty-crossplatform version: 0.4.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.1 if os(darwin) build-depends: vty-unix elif os(linux) build-depends: vty-unix elif os(freebsd) || os(openbsd) || os(netbsd) || os(dragonfly) build-depends: vty-unix elif os(solaris) || os(aix) || os(hpux) || os(irix) || os(hurd) build-depends: vty-unix elif os(windows) build-depends: vty-windows >= 0.2.0.0 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