mirror of
https://github.com/ilyakooo0/vty.git
synced 2024-10-04 03:07:07 +03:00
Library-wide trailing whitespace cleanup
This commit is contained in:
Jonathan Daugherty
parent
a69c4b8a04
commit
ba2b6356ea
@ -1,6 +1,6 @@
|
||||
{-# OPTIONS_HADDOCK hide #-}
|
||||
-- Copyright 2009 Corey O'Connor
|
||||
module Codec.Binary.UTF8.Debug
|
||||
module Codec.Binary.UTF8.Debug
|
||||
where
|
||||
|
||||
import Codec.Binary.UTF8.String ( encode )
|
||||
|
||||
@ -7,7 +7,7 @@ import Data.Sequence
|
||||
import Control.Parallel.Strategies
|
||||
|
||||
instance NFData a => NFData (Seq a) where
|
||||
rnf = \v -> rnf' (viewl v)
|
||||
where
|
||||
rnf = \v -> rnf' (viewl v)
|
||||
where
|
||||
rnf' EmptyL = ()
|
||||
rnf' (a :< r) = rnf a >| rnf' (viewl r)
|
||||
|
||||
@ -83,7 +83,7 @@ writeCapOp DecOut = do
|
||||
p <- pop
|
||||
forM_ (show p) $ tell.writeWord8.toEnum.fromEnum
|
||||
writeCapOp CharOut = do
|
||||
pop >>= tell.writeWord8.toEnum.fromEnum
|
||||
pop >>= tell.writeWord8.toEnum.fromEnum
|
||||
writeCapOp (PushParam pn) = do
|
||||
readParam pn >>= push
|
||||
writeCapOp (PushValue v) = do
|
||||
@ -91,7 +91,7 @@ writeCapOp (PushValue v) = do
|
||||
writeCapOp (Conditional expr parts) = do
|
||||
writeCapOps expr
|
||||
writeContitionalParts parts
|
||||
where
|
||||
where
|
||||
writeContitionalParts [] = return ()
|
||||
writeContitionalParts ((trueOps, falseOps) : falseParts) = do
|
||||
-- (man 5 terminfo)
|
||||
@ -137,4 +137,3 @@ writeCapOp CompareGt = do
|
||||
v1 <- pop
|
||||
v0 <- pop
|
||||
push $ if v0 > v1 then 1 else 0
|
||||
|
||||
|
||||
@ -46,13 +46,13 @@ instance Show CapExpression where
|
||||
hexDump = foldr (\b s -> showHex b s) ""
|
||||
|
||||
instance NFData CapExpression where
|
||||
rnf (CapExpression ops !_bytes !str !c !pOps)
|
||||
rnf (CapExpression ops !_bytes !str !c !pOps)
|
||||
= rnf ops `seq` rnf str `seq` rnf c `seq` rnf pOps
|
||||
|
||||
type CapParam = Word
|
||||
|
||||
type CapOps = [CapOp]
|
||||
data CapOp =
|
||||
data CapOp =
|
||||
Bytes !Int !Int -- offset count
|
||||
| DecOut | CharOut
|
||||
-- This stores a 0-based index to the parameter. However the operation that implies this op is
|
||||
@ -60,7 +60,7 @@ data CapOp =
|
||||
| PushParam !Word | PushValue !Word
|
||||
-- The conditional parts are the sequence of (%t expression, %e expression) pairs.
|
||||
-- The %e expression may be NOP
|
||||
| Conditional
|
||||
| Conditional
|
||||
{ conditionalExpr :: !CapOps
|
||||
, conditionalParts :: ![(CapOps, CapOps)]
|
||||
}
|
||||
@ -72,8 +72,8 @@ data CapOp =
|
||||
instance NFData CapOp where
|
||||
rnf (Bytes offset byteCount ) = rnf offset `seq` rnf byteCount
|
||||
rnf (PushParam pn) = rnf pn
|
||||
rnf (PushValue v) = rnf v
|
||||
rnf (Conditional cExpr cParts) = rnf cExpr `seq` rnf cParts
|
||||
rnf (PushValue v) = rnf v
|
||||
rnf (Conditional cExpr cParts) = rnf cExpr `seq` rnf cParts
|
||||
rnf BitwiseOr = ()
|
||||
rnf BitwiseXOr = ()
|
||||
rnf BitwiseAnd = ()
|
||||
@ -94,11 +94,11 @@ instance NFData ParamOp where
|
||||
rnf IncFirstTwo = ()
|
||||
|
||||
parseCapExpression :: String -> Either ParseError CapExpression
|
||||
parseCapExpression capString =
|
||||
parseCapExpression capString =
|
||||
let v = runParser capExpressionParser
|
||||
initialBuildState
|
||||
"terminfo cap"
|
||||
capString
|
||||
"terminfo cap"
|
||||
capString
|
||||
in case v of
|
||||
Left e -> Left e
|
||||
Right buildResults -> Right $ constructCapExpression capString buildResults
|
||||
@ -113,21 +113,21 @@ constructCapExpression capString buildResults =
|
||||
, sourceString = capString
|
||||
, paramCount = outParamCount buildResults
|
||||
, paramOps = outParamOps buildResults
|
||||
}
|
||||
}
|
||||
in rnf expr `seq` expr
|
||||
|
||||
type CapParser a = Parsec String BuildState a
|
||||
type CapParser a = Parsec String BuildState a
|
||||
|
||||
capExpressionParser :: CapParser BuildResults
|
||||
capExpressionParser = do
|
||||
rs <- many $ paramEscapeParser <|> bytesOpParser
|
||||
rs <- many $ paramEscapeParser <|> bytesOpParser
|
||||
return $ mconcat rs
|
||||
|
||||
paramEscapeParser :: CapParser BuildResults
|
||||
paramEscapeParser = do
|
||||
_ <- char '%'
|
||||
incOffset 1
|
||||
literalPercentParser <|> paramOpParser
|
||||
literalPercentParser <|> paramOpParser
|
||||
|
||||
literalPercentParser :: CapParser BuildResults
|
||||
literalPercentParser = do
|
||||
@ -138,7 +138,7 @@ literalPercentParser = do
|
||||
|
||||
paramOpParser :: CapParser BuildResults
|
||||
paramOpParser
|
||||
= incrementOpParser
|
||||
= incrementOpParser
|
||||
<|> pushOpParser
|
||||
<|> decOutParser
|
||||
<|> charOutParser
|
||||
@ -179,16 +179,16 @@ conditionalOpParser = do
|
||||
_ <- char '?'
|
||||
incOffset 1
|
||||
condPart <- manyExpr conditionalTrueParser
|
||||
parts <- manyP
|
||||
parts <- manyP
|
||||
( do
|
||||
truePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser
|
||||
, conditionalFalseParser
|
||||
, conditionalFalseParser
|
||||
]
|
||||
falsePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser
|
||||
, conditionalTrueParser
|
||||
]
|
||||
return ( truePart, falsePart )
|
||||
)
|
||||
)
|
||||
conditionalEndParser
|
||||
|
||||
let trueParts = map fst parts
|
||||
@ -208,10 +208,10 @@ conditionalOpParser = do
|
||||
|
||||
return $ BuildResults n'' [ Conditional cond condParts ] pOps
|
||||
|
||||
where
|
||||
manyP !p !end = choice
|
||||
where
|
||||
manyP !p !end = choice
|
||||
[ try end >> return []
|
||||
, do !v <- p
|
||||
, do !v <- p
|
||||
!vs <- manyP p end
|
||||
return $! v : vs
|
||||
]
|
||||
@ -233,7 +233,7 @@ conditionalEndParser = do
|
||||
incOffset 2
|
||||
|
||||
bitwiseOpParser :: CapParser BuildResults
|
||||
bitwiseOpParser
|
||||
bitwiseOpParser
|
||||
= bitwiseOrParser
|
||||
<|> bitwiseAndParser
|
||||
<|> bitwiseXorParser
|
||||
@ -257,9 +257,9 @@ bitwiseXorParser = do
|
||||
return $ BuildResults 0 [ BitwiseXOr ] [ ]
|
||||
|
||||
arithOpParser :: CapParser BuildResults
|
||||
arithOpParser
|
||||
= plusOp
|
||||
<|> minusOp
|
||||
arithOpParser
|
||||
= plusOp
|
||||
<|> minusOp
|
||||
where
|
||||
plusOp = do
|
||||
_ <- char '+'
|
||||
@ -282,10 +282,10 @@ literalIntOpParser = do
|
||||
return $ BuildResults 0 [ PushValue n ] [ ]
|
||||
|
||||
compareOpParser :: CapParser BuildResults
|
||||
compareOpParser
|
||||
compareOpParser
|
||||
= compareEqOp
|
||||
<|> compareLtOp
|
||||
<|> compareGtOp
|
||||
<|> compareLtOp
|
||||
<|> compareGtOp
|
||||
where
|
||||
compareEqOp = do
|
||||
_ <- char '='
|
||||
@ -313,14 +313,14 @@ bytesOpParser = do
|
||||
charConstParser :: CapParser BuildResults
|
||||
charConstParser = do
|
||||
_ <- char '\''
|
||||
charValue <- liftM (toEnum . fromEnum) anyChar
|
||||
charValue <- liftM (toEnum . fromEnum) anyChar
|
||||
_ <- char '\''
|
||||
incOffset 3
|
||||
return $ BuildResults 0 [ PushValue charValue ] [ ]
|
||||
|
||||
data BuildState = BuildState
|
||||
data BuildState = BuildState
|
||||
{ nextOffset :: Int
|
||||
}
|
||||
}
|
||||
|
||||
incOffset :: Int -> CapParser ()
|
||||
incOffset n = do
|
||||
@ -339,10 +339,9 @@ data BuildResults = BuildResults
|
||||
|
||||
instance Monoid BuildResults where
|
||||
mempty = BuildResults 0 [] []
|
||||
v0 `mappend` v1
|
||||
v0 `mappend` v1
|
||||
= BuildResults
|
||||
{ outParamCount = (outParamCount v0) `max` (outParamCount v1)
|
||||
, outCapOps = (outCapOps v0) `mappend` (outCapOps v1)
|
||||
, outParamOps = (outParamOps v0) `mappend` (outParamOps v1)
|
||||
}
|
||||
|
||||
|
||||
@ -14,7 +14,7 @@ wcswidth :: String -> Int
|
||||
wcswidth = sum . map wcwidth
|
||||
|
||||
-- XXX: Characters with unknown widths occupy 1 column?
|
||||
--
|
||||
--
|
||||
-- Not sure if this is actually correct. I presume there is a replacement character that is output
|
||||
-- by the terminal instead of the character and this replacement character is 1 column wide. If this
|
||||
-- is not true for all terminals then a per-terminal replacement character width needs to be
|
||||
|
||||
@ -10,7 +10,7 @@
|
||||
-- - The constructors in "Graphics.Vty.Image.Internal" should not be used.
|
||||
--
|
||||
-- - 'Image's can be styled using 'Attr'. See "Graphics.Vty.Attributes".
|
||||
--
|
||||
--
|
||||
-- See the vty-examples package for a number of examples.
|
||||
--
|
||||
-- @
|
||||
@ -28,7 +28,7 @@
|
||||
-- 'shutdown' vty
|
||||
-- 'print' (\"Last event was: \" '++' 'show' e)
|
||||
-- @
|
||||
--
|
||||
--
|
||||
-- Good sources of documentation for terminal programming are:
|
||||
--
|
||||
-- - <https://github.com/b4winckler/vim/blob/master/src/term.c>
|
||||
@ -50,7 +50,7 @@ module Graphics.Vty ( Vty(..)
|
||||
, module Graphics.Vty.Picture
|
||||
, DisplayRegion
|
||||
, Mode(..)
|
||||
)
|
||||
)
|
||||
where
|
||||
|
||||
import Graphics.Vty.Prelude
|
||||
@ -84,7 +84,7 @@ import Data.Monoid
|
||||
-- when another update action is already then it's safe to call this on multiple threads.
|
||||
--
|
||||
-- \todo Remove explicit `shutdown` requirement.
|
||||
data Vty = Vty
|
||||
data Vty = Vty
|
||||
{ -- | Outputs the given Picture. Equivalent to 'outputPicture' applied to a display context
|
||||
-- implicitly managed by Vty. The managed display context is reset on resize.
|
||||
update :: Picture -> IO ()
|
||||
@ -101,7 +101,7 @@ data Vty = Vty
|
||||
, refresh :: IO ()
|
||||
-- | Clean up after vty.
|
||||
-- The above methods will throw an exception if executed after this is executed.
|
||||
, shutdown :: IO ()
|
||||
, shutdown :: IO ()
|
||||
}
|
||||
|
||||
-- | Set up the state object for using vty. At most one state object should be
|
||||
@ -157,7 +157,7 @@ intMkVty input out = do
|
||||
maybe (return ()) innerUpdate mPic
|
||||
|
||||
let gkey = do k <- atomically $ readTChan $ _eventChannel input
|
||||
case k of
|
||||
case k of
|
||||
(EvResize _ _) -> displayBounds out
|
||||
>>= return . (\(w,h)-> EvResize w h)
|
||||
_ -> return k
|
||||
@ -169,4 +169,3 @@ intMkVty input out = do
|
||||
, refresh = innerRefresh
|
||||
, shutdown = shutdownIo
|
||||
}
|
||||
|
||||
|
||||
@ -93,7 +93,7 @@ data Attr = Attr
|
||||
|
||||
instance Monoid Attr where
|
||||
mempty = Attr mempty mempty mempty
|
||||
mappend attr0 attr1 =
|
||||
mappend attr0 attr1 =
|
||||
Attr ( attrStyle attr0 `mappend` attrStyle attr1 )
|
||||
( attrForeColor attr0 `mappend` attrForeColor attr1 )
|
||||
( attrBackColor attr0 `mappend` attrBackColor attr1 )
|
||||
@ -141,7 +141,7 @@ magenta= ISOColor 5
|
||||
cyan = ISOColor 6
|
||||
white = ISOColor 7
|
||||
|
||||
-- | Bright/Vivid variants of the standard 8-color ANSI
|
||||
-- | Bright/Vivid variants of the standard 8-color ANSI
|
||||
brightBlack, brightRed, brightGreen, brightYellow :: Color
|
||||
brightBlue, brightMagenta, brightCyan, brightWhite :: Color
|
||||
brightBlack = ISOColor 8
|
||||
@ -185,7 +185,7 @@ defaultStyleMask :: Style
|
||||
defaultStyleMask = 0x00
|
||||
|
||||
styleMask :: Attr -> Word8
|
||||
styleMask attr
|
||||
styleMask attr
|
||||
= case attrStyle attr of
|
||||
Default -> 0
|
||||
KeepCurrent -> 0
|
||||
@ -224,4 +224,3 @@ instance Default Attr where
|
||||
-- set to brightMagenta.
|
||||
currentAttr :: Attr
|
||||
currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent
|
||||
|
||||
|
||||
@ -2,7 +2,7 @@ module Graphics.Vty.Attributes.Color where
|
||||
import Data.Word
|
||||
|
||||
-- | Abstract data type representing a color.
|
||||
--
|
||||
--
|
||||
-- Currently the foreground and background color are specified as points in either a:
|
||||
--
|
||||
-- * 16 color palette. Where the first 8 colors are equal to the 8 colors of the ISO 6429 (ANSI) 8
|
||||
@ -10,7 +10,7 @@ import Data.Word
|
||||
--
|
||||
-- * 240 color palette. This palette is a regular sampling of the full RGB colorspace for the first
|
||||
-- 224 colors. The remaining 16 colors is a greyscale palette.
|
||||
--
|
||||
--
|
||||
-- The 8 ISO 6429 (ANSI) colors are as follows:
|
||||
--
|
||||
-- 0. black
|
||||
@ -36,7 +36,7 @@ import Data.Word
|
||||
--
|
||||
-- If the terminal reports <= 16 colors then the 240 color palette points are only mapped to the 8
|
||||
-- color pallete. I'm not sure of the RGB points for the "bright" colors which is why they are not
|
||||
-- addressable via the 240 color palette.
|
||||
-- addressable via the 240 color palette.
|
||||
--
|
||||
-- If the terminal reports > 16 colors then the 240 color palette points are mapped to the nearest
|
||||
-- points in a ("color count" - 16) subsampling of the 240 color palette.
|
||||
@ -48,4 +48,3 @@ import Data.Word
|
||||
-- Seriously, terminal color support is INSANE.
|
||||
data Color = ISOColor !Word8 | Color240 !Word8
|
||||
deriving ( Eq, Show, Read )
|
||||
|
||||
|
||||
@ -254,7 +254,7 @@ rgbColor r g b
|
||||
| r <= 255 && g <= 255 && b <= 175 = Color240 213
|
||||
| r <= 255 && g <= 255 && b <= 215 = Color240 214
|
||||
| r <= 255 && g <= 255 && b <= 255 = Color240 215
|
||||
| otherwise = error (printf "RGB color %d %d %d does not map to 240 palette."
|
||||
| otherwise = error (printf "RGB color %d %d %d does not map to 240 palette."
|
||||
(fromIntegral r :: Int)
|
||||
(fromIntegral g :: Int)
|
||||
(fromIntegral b :: Int))
|
||||
|
||||
@ -14,7 +14,7 @@
|
||||
-- earlier.
|
||||
--
|
||||
-- For all directives:
|
||||
--
|
||||
--
|
||||
-- @
|
||||
-- string := \"\\\"\" chars+ \"\\\"\"
|
||||
-- @
|
||||
@ -40,7 +40,7 @@
|
||||
--
|
||||
-- @
|
||||
-- \"map\" term string key modifier_list
|
||||
-- where
|
||||
-- where
|
||||
-- key := KEsc | KChar Char | KBS ... (same as 'Key')
|
||||
-- modifier_list := \"[\" modifier+ \"]\"
|
||||
-- modifier := MShift | MCtrl | MMeta | MAlt
|
||||
|
||||
@ -10,10 +10,10 @@ import Graphics.Vty.Attributes
|
||||
import Graphics.Vty.Debug.Image
|
||||
import Graphics.Vty.Span
|
||||
|
||||
import qualified Data.Vector as Vector
|
||||
import qualified Data.Vector as Vector
|
||||
|
||||
rowOpsEffectedColumns :: DisplayOps -> [Int]
|
||||
rowOpsEffectedColumns ops
|
||||
rowOpsEffectedColumns ops
|
||||
= Vector.toList $ Vector.map spanOpsEffectedColumns ops
|
||||
|
||||
allSpansHaveWidth :: DisplayOps -> Int -> Bool
|
||||
@ -23,7 +23,7 @@ allSpansHaveWidth ops expected
|
||||
spanOpsEffectedRows :: DisplayOps -> Int
|
||||
spanOpsEffectedRows ops
|
||||
= toEnum $ length (filter (not . null . Vector.toList) (Vector.toList ops))
|
||||
|
||||
|
||||
type SpanConstructLog = [SpanConstructEvent]
|
||||
data SpanConstructEvent = SpanSetAttr Attr
|
||||
|
||||
@ -37,4 +37,3 @@ data MockWindow = MockWindow Int Int
|
||||
|
||||
regionForWindow :: MockWindow -> DisplayRegion
|
||||
regionForWindow (MockWindow w h) = (w,h)
|
||||
|
||||
|
||||
@ -19,7 +19,7 @@ data ImageOp = ImageOp ImageEndo ImageEndo
|
||||
type ImageEndo = Image -> Image
|
||||
|
||||
debugImageOps :: [ImageOp]
|
||||
debugImageOps =
|
||||
debugImageOps =
|
||||
[ idImageOp
|
||||
-- , renderSingleColumnCharOp
|
||||
-- , renderDoubleColumnCharOp
|
||||
|
||||
@ -79,7 +79,7 @@ data DisplayColorDiff
|
||||
|
||||
-- | Style attribute changes are transformed into a sequence of apply/removes of the individual
|
||||
-- attributes.
|
||||
data StyleStateChange
|
||||
data StyleStateChange
|
||||
= ApplyStandout
|
||||
| RemoveStandout
|
||||
| ApplyUnderline
|
||||
|
||||
@ -61,7 +61,7 @@ infixr 4 <->
|
||||
|
||||
-- | An area of the picture's bacground (See Background) of w columns and h rows.
|
||||
backgroundFill :: Int -> Int -> Image
|
||||
backgroundFill w h
|
||||
backgroundFill w h
|
||||
| w == 0 = EmptyImage
|
||||
| h == 0 = EmptyImage
|
||||
| otherwise = BGFill w h
|
||||
@ -104,21 +104,21 @@ char a c =
|
||||
in HorizText a (TL.singleton c) displayWidth 1
|
||||
|
||||
-- | A string of characters layed out on a single row with the same display attribute. The string is
|
||||
-- assumed to be a sequence of ISO-10646 characters.
|
||||
-- assumed to be a sequence of ISO-10646 characters.
|
||||
--
|
||||
-- Note: depending on how the Haskell compiler represents string literals a string literal in a
|
||||
-- UTF-8 encoded source file, for example, may be represented as a ISO-10646 string.
|
||||
-- UTF-8 encoded source file, for example, may be represented as a ISO-10646 string.
|
||||
-- That is, I think, the case with GHC 6.10. This means, for the most part, you don't need to worry
|
||||
-- about the encoding format when outputting string literals. Just provide the string literal
|
||||
-- directly to iso10646String or string.
|
||||
--
|
||||
--
|
||||
iso10646String :: Attr -> String -> Image
|
||||
iso10646String a str =
|
||||
let displayWidth = safeWcswidth str
|
||||
in HorizText a (TL.pack str) displayWidth (length str)
|
||||
|
||||
-- | Alias for iso10646String. Since the usual case is that a literal string like "foo" is
|
||||
-- represented internally as a list of ISO 10646 31 bit characters.
|
||||
-- represented internally as a list of ISO 10646 31 bit characters.
|
||||
--
|
||||
-- Note: Keep in mind that GHC will compile source encoded as UTF-8 but the literal strings, while
|
||||
-- UTF-8 encoded in the source, will be transcoded to a ISO 10646 31 bit characters runtime
|
||||
@ -131,11 +131,11 @@ string = iso10646String
|
||||
utf8String :: Attr -> [Word8] -> Image
|
||||
utf8String a bytes = utf8Bytestring a (BL.pack bytes)
|
||||
|
||||
-- | Renders a UTF-8 encoded lazy bytestring.
|
||||
-- | Renders a UTF-8 encoded lazy bytestring.
|
||||
utf8Bytestring :: Attr -> BL.ByteString -> Image
|
||||
utf8Bytestring a bs = text a (TL.decodeUtf8 bs)
|
||||
|
||||
-- | Renders a UTF-8 encoded strict bytestring.
|
||||
-- | Renders a UTF-8 encoded strict bytestring.
|
||||
utf8Bytestring' :: Attr -> B.ByteString -> Image
|
||||
utf8Bytestring' a bs = text' a (T.decodeUtf8 bs)
|
||||
|
||||
@ -146,14 +146,14 @@ charFill _a _c 0 _h = EmptyImage
|
||||
charFill _a _c _w 0 = EmptyImage
|
||||
charFill a c w h =
|
||||
vertCat $ replicate (fromIntegral h) $ HorizText a txt displayWidth charWidth
|
||||
where
|
||||
where
|
||||
txt = TL.replicate (fromIntegral w) (TL.singleton c)
|
||||
displayWidth = safeWcwidth c * (fromIntegral w)
|
||||
charWidth = fromIntegral w
|
||||
|
||||
-- | The empty image. Useful for fold combinators. These occupy no space nor define any display
|
||||
-- attributes.
|
||||
emptyImage :: Image
|
||||
emptyImage :: Image
|
||||
emptyImage = EmptyImage
|
||||
|
||||
-- | pad the given image. This adds background character fills to the left, top, right, bottom.
|
||||
@ -163,7 +163,7 @@ pad 0 0 0 0 i = i
|
||||
pad inL inT inR inB inImage
|
||||
| inL < 0 || inT < 0 || inR < 0 || inB < 0 = error "cannot pad by negative amount"
|
||||
| otherwise = go inL inT inR inB inImage
|
||||
where
|
||||
where
|
||||
-- TODO: uh.
|
||||
go 0 0 0 0 i = i
|
||||
go 0 0 0 b i = VertJoin i (BGFill w b) w h
|
||||
@ -299,4 +299,3 @@ resizeHeight h i = case h `compare` imageHeight i of
|
||||
LT -> cropBottom h i
|
||||
EQ -> i
|
||||
GT -> i <-> BGFill (imageWidth i) (h - imageHeight i)
|
||||
|
||||
|
||||
@ -65,7 +65,7 @@ clipText txt leftSkip rightClip =
|
||||
-- * a cropped image
|
||||
--
|
||||
-- * an empty image of no size or content.
|
||||
data Image =
|
||||
data Image =
|
||||
-- | A horizontal text span has a row height of 1.
|
||||
HorizText
|
||||
{ attr :: Attr
|
||||
@ -80,7 +80,7 @@ data Image =
|
||||
-- required to be between two images of equal height. The horizJoin constructor adds background
|
||||
-- fills to the provided images that assure this is true for the HorizJoin value produced.
|
||||
| HorizJoin
|
||||
{ partLeft :: Image
|
||||
{ partLeft :: Image
|
||||
, partRight :: Image
|
||||
, outputWidth :: Int -- ^ imageWidth partLeft == imageWidth partRight. Always > 0
|
||||
, outputHeight :: Int -- ^ imageHeight partLeft == imageHeight partRight. Always > 0
|
||||
@ -136,10 +136,10 @@ data Image =
|
||||
}
|
||||
-- | The empty image
|
||||
--
|
||||
-- The combining operators identity constant.
|
||||
-- The combining operators identity constant.
|
||||
-- EmptyImage <|> a = a
|
||||
-- EmptyImage <-> a = a
|
||||
--
|
||||
--
|
||||
-- Any image of zero size equals the empty image.
|
||||
| EmptyImage
|
||||
deriving (Eq, Generic)
|
||||
@ -198,7 +198,7 @@ ppImageStructure inImg = go 0 inImg
|
||||
= "CropTop("++ show outputWidth ++ "," ++ show topSkip ++ "->" ++ show outputHeight ++ ")\n"
|
||||
++ go (i+1) croppedImage
|
||||
pp _ EmptyImage = "EmptyImage"
|
||||
|
||||
|
||||
instance NFData Image where
|
||||
rnf EmptyImage = ()
|
||||
rnf (CropRight i w h) = i `deepseq` w `seq` h `seq` ()
|
||||
@ -234,7 +234,7 @@ imageHeight CropBottom { outputHeight = h } = h
|
||||
imageHeight CropTop { outputHeight = h } = h
|
||||
imageHeight EmptyImage = 0
|
||||
|
||||
-- | Append in the Monoid instance is equivalent to <->.
|
||||
-- | Append in the Monoid instance is equivalent to <->.
|
||||
instance Monoid Image where
|
||||
mempty = EmptyImage
|
||||
mappend = vertJoin
|
||||
@ -302,4 +302,3 @@ vertJoin i0 i1
|
||||
h1 = imageHeight i1
|
||||
h = h0 + h1
|
||||
vertJoin _ _ = error "vertJoin applied to undefined values."
|
||||
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
-- | The inline module provides a limited interface to changing the style of terminal output. The
|
||||
-- intention is for this interface to be used inline with other output systems.
|
||||
-- intention is for this interface to be used inline with other output systems.
|
||||
--
|
||||
-- The changes specified by the InlineM monad are applied to the terminals display attributes. These
|
||||
-- display attributes effect the display of all following text output to the terminal file
|
||||
@ -11,7 +11,7 @@
|
||||
-- @
|
||||
-- putStr \"Not styled. \"
|
||||
-- putAttrChange_ $ do
|
||||
-- backColor red
|
||||
-- backColor red
|
||||
-- applyStyle underline
|
||||
-- putStr \" Styled! \"
|
||||
-- putAttrChange_ $ defaultAll
|
||||
@ -74,14 +74,14 @@ applyStyle s = modify $ flip mappend ( currentAttr `withStyle` s )
|
||||
|
||||
-- | Attempt to remove the specified 'Style' from the display of the following text.
|
||||
--
|
||||
-- This will fail if applyStyle for the given style has not been previously called.
|
||||
-- This will fail if applyStyle for the given style has not been previously called.
|
||||
removeStyle :: Style -> InlineM ()
|
||||
removeStyle sMask = modify $ \attr ->
|
||||
removeStyle sMask = modify $ \attr ->
|
||||
let style' = case attrStyle attr of
|
||||
Default -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
|
||||
KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."
|
||||
SetTo s -> s .&. complement sMask
|
||||
in attr { attrStyle = SetTo style' }
|
||||
in attr { attrStyle = SetTo style' }
|
||||
|
||||
-- | Reset the display attributes
|
||||
defaultAll :: InlineM ()
|
||||
|
||||
@ -113,7 +113,7 @@
|
||||
-- Some terminfo capabilities specify millisecond delays. (Capabilities are how terminfo describes
|
||||
-- the control sequence to output red, for instance) This is to account for the slow speed of
|
||||
-- hardcopy teletype interfaces. Cause, uh, we totally still use those.
|
||||
--
|
||||
--
|
||||
-- The output encoding of colors and attributes are also rife with issues.
|
||||
--
|
||||
-- == See also
|
||||
@ -162,7 +162,7 @@ import Data.Monoid ((<>))
|
||||
-- suspended if the output terminal cannot keep up. I presume this has little effect these
|
||||
-- days. I hope this means that output will be buffered if the terminal cannot keep up. In the
|
||||
-- old days the output might of been dropped?
|
||||
--
|
||||
--
|
||||
-- "raw" mode is used for input.
|
||||
--
|
||||
-- * ISIG disabled
|
||||
|
||||
@ -44,7 +44,7 @@ compile table = cl' where
|
||||
-- produced.
|
||||
-- The test verifyFullSynInputToEvent2x verifies this.
|
||||
-- H: There will always be one match. The prefixSet contains, by definition, all
|
||||
-- prefixes of an event.
|
||||
-- prefixes of an event.
|
||||
False ->
|
||||
let inputPrefixes = reverse $ take maxValidInputLength $ tail $ inits inputBlock
|
||||
in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputPrefixes of
|
||||
|
||||
@ -147,7 +147,7 @@ parseEvent = do
|
||||
logMsg $ "remaining: " ++ show remaining
|
||||
unprocessedBytes .= remaining
|
||||
return e
|
||||
_ -> mzero
|
||||
_ -> mzero
|
||||
|
||||
dropInvalid :: InputM ()
|
||||
dropInvalid = do
|
||||
|
||||
@ -113,7 +113,7 @@ specialSupportKeys =
|
||||
-- * kcbt - back tab
|
||||
--
|
||||
-- * kc1 - keypad left-down
|
||||
--
|
||||
--
|
||||
-- * kc3 - keypad right-down
|
||||
--
|
||||
-- * kdch1 - delete
|
||||
@ -121,7 +121,7 @@ specialSupportKeys =
|
||||
-- * kcud1 - down
|
||||
--
|
||||
-- * kend - end
|
||||
--
|
||||
--
|
||||
-- * kent - enter
|
||||
--
|
||||
-- * kf0 - kf63 - function keys
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
-- | Input mappings for ANSI/VT100/VT50 terminals that is missing from terminfo.
|
||||
--
|
||||
--
|
||||
-- Or that are sent regardless of terminfo by terminal emulators. EG: Terminal emulators will often
|
||||
-- use VT50 input bytes regardless of declared terminal type. This provides compatibility with
|
||||
-- programs that don't follow terminfo.
|
||||
@ -49,8 +49,8 @@ navKeys3 =
|
||||
[KIns,KDel,KPageUp,KPageDown,KHome,KEnd]
|
||||
|
||||
-- | encoding for shift plus function keys
|
||||
--
|
||||
-- According to
|
||||
--
|
||||
-- According to
|
||||
--
|
||||
-- * http://aperiodic.net/phil/archives/Geekery/term-function-keys.html
|
||||
--
|
||||
@ -84,4 +84,3 @@ classifyTable =
|
||||
, functionKeys1
|
||||
, functionKeys2
|
||||
]
|
||||
|
||||
|
||||
@ -43,12 +43,12 @@ data Mode = Mouse
|
||||
deriving (Eq, Read, Show)
|
||||
|
||||
data Output = Output
|
||||
{ -- | Text identifier for the output device. Used for debugging.
|
||||
{ -- | Text identifier for the output device. Used for debugging.
|
||||
terminalID :: String
|
||||
, releaseTerminal :: forall m. MonadIO m => m ()
|
||||
-- | Clear the display and initialize the terminal to some initial display state.
|
||||
-- | Clear the display and initialize the terminal to some initial display state.
|
||||
--
|
||||
-- The expectation of a program is that the display starts in some initial state.
|
||||
-- The expectation of a program is that the display starts in some initial state.
|
||||
-- The initial state would consist of fixed values:
|
||||
--
|
||||
-- - cursor at top left
|
||||
@ -80,7 +80,7 @@ data Output = Output
|
||||
, getModeStatus :: forall m. MonadIO m => Mode -> m Bool
|
||||
, assumedStateRef :: IORef AssumedState
|
||||
-- | Acquire display access to the given region of the display.
|
||||
-- Currently all regions have the upper left corner of (0,0) and the lower right corner at
|
||||
-- Currently all regions have the upper left corner of (0,0) and the lower right corner at
|
||||
-- (max displayWidth providedWidth, max displayHeight providedHeight)
|
||||
, mkDisplayContext :: forall m. MonadIO m => Output -> DisplayRegion -> m DisplayContext
|
||||
-- | Ring the terminal bell if supported.
|
||||
@ -102,7 +102,7 @@ initialAssumedState = AssumedState Nothing Nothing
|
||||
|
||||
data DisplayContext = DisplayContext
|
||||
{ contextDevice :: Output
|
||||
-- | Provide the bounds of the display context.
|
||||
-- | Provide the bounds of the display context.
|
||||
, contextRegion :: DisplayRegion
|
||||
-- | sets the output position to the specified row and column. Where the number of bytes
|
||||
-- required for the control codes can be specified seperate from the actual byte sequence.
|
||||
@ -134,16 +134,16 @@ writeUtf8Text = writeByteString
|
||||
|
||||
-- | Displays the given `Picture`.
|
||||
--
|
||||
-- 0. The image is cropped to the display size.
|
||||
-- 0. The image is cropped to the display size.
|
||||
--
|
||||
-- 1. Converted into a sequence of attribute changes and text spans.
|
||||
--
|
||||
--
|
||||
-- 2. The cursor is hidden.
|
||||
--
|
||||
-- 3. Serialized to the display.
|
||||
--
|
||||
-- 4. The cursor is then shown and positioned or kept hidden.
|
||||
--
|
||||
--
|
||||
-- todo: specify possible IO exceptions.
|
||||
-- abstract from IO monad to a MonadIO instance.
|
||||
outputPicture :: MonadIO m => DisplayContext -> Picture -> m ()
|
||||
@ -193,7 +193,7 @@ writeOutputOps dc initialAttr diffs ops =
|
||||
(0, mempty, diffs)
|
||||
ops
|
||||
in out
|
||||
where
|
||||
where
|
||||
writeOutputOps' (y, out, True : diffs') spanOps
|
||||
= let spanOut = writeSpanOps dc y initialAttr spanOps
|
||||
out' = out `mappend` spanOut
|
||||
@ -229,7 +229,7 @@ writeSpanOp dc (RowEnd _) fattr = (writeDefaultAttr dc `mappend` writeRowEnd dc,
|
||||
-- needs to be translated to column, row positions.
|
||||
data CursorOutputMap = CursorOutputMap
|
||||
{ charToOutputPos :: (Int, Int) -> (Int, Int)
|
||||
}
|
||||
}
|
||||
|
||||
cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap
|
||||
cursorOutputMap spanOps _cursor = CursorOutputMap
|
||||
@ -239,18 +239,18 @@ cursorOutputMap spanOps _cursor = CursorOutputMap
|
||||
cursorColumnOffset :: DisplayOps -> Int -> Int -> Int
|
||||
cursorColumnOffset ops cx cy =
|
||||
let cursorRowOps = Vector.unsafeIndex ops (fromEnum cy)
|
||||
(outOffset, _, _)
|
||||
= Vector.foldl' ( \(d, currentCx, done) op ->
|
||||
(outOffset, _, _)
|
||||
= Vector.foldl' ( \(d, currentCx, done) op ->
|
||||
if done then (d, currentCx, done) else case spanOpHasWidth op of
|
||||
Nothing -> (d, currentCx, False)
|
||||
Just (cw, ow) -> case compare cx (currentCx + cw) of
|
||||
GT -> ( d + ow
|
||||
, currentCx + cw
|
||||
, False
|
||||
, False
|
||||
)
|
||||
EQ -> ( d + ow
|
||||
, currentCx + cw
|
||||
, True
|
||||
, True
|
||||
)
|
||||
LT -> ( d + columnsToCharOffset (cx - currentCx) op
|
||||
, currentCx + cw
|
||||
@ -264,7 +264,7 @@ cursorColumnOffset ops cx cy =
|
||||
-- | Not all terminals support all display attributes. This filters a display attribute to what the
|
||||
-- given terminal can display.
|
||||
limitAttrForDisplay :: Output -> Attr -> Attr
|
||||
limitAttrForDisplay t attr
|
||||
limitAttrForDisplay t attr
|
||||
= attr { attrForeColor = clampColor $ attrForeColor attr
|
||||
, attrBackColor = clampColor $ attrBackColor attr
|
||||
}
|
||||
@ -272,7 +272,7 @@ limitAttrForDisplay t attr
|
||||
clampColor Default = Default
|
||||
clampColor KeepCurrent = KeepCurrent
|
||||
clampColor (SetTo c) = clampColor' c
|
||||
clampColor' (ISOColor v)
|
||||
clampColor' (ISOColor v)
|
||||
| contextColorCount t < 8 = Default
|
||||
| contextColorCount t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)
|
||||
| otherwise = SetTo $ ISOColor v
|
||||
@ -281,7 +281,7 @@ limitAttrForDisplay t attr
|
||||
| contextColorCount t < 8 = Default
|
||||
| contextColorCount t < 16 = Default
|
||||
| contextColorCount t <= 256 = SetTo $ Color240 v
|
||||
| otherwise
|
||||
= let p :: Double = fromIntegral v / 240.0
|
||||
| otherwise
|
||||
= let p :: Double = fromIntegral v / 240.0
|
||||
v' = floor $ p * (fromIntegral $ contextColorCount t)
|
||||
in SetTo $ Color240 v'
|
||||
|
||||
@ -50,7 +50,7 @@ import Data.Foldable (foldMap)
|
||||
import Data.Monoid
|
||||
#endif
|
||||
|
||||
data TerminfoCaps = TerminfoCaps
|
||||
data TerminfoCaps = TerminfoCaps
|
||||
{ smcup :: Maybe CapExpression
|
||||
, rmcup :: Maybe CapExpression
|
||||
, cup :: CapExpression
|
||||
@ -77,7 +77,7 @@ data DisplayAttrCaps = DisplayAttrCaps
|
||||
, enterDimMode :: Maybe CapExpression
|
||||
, enterBoldMode :: Maybe CapExpression
|
||||
}
|
||||
|
||||
|
||||
-- kinda like: https://code.google.com/p/vim/source/browse/src/fileio.c#10422
|
||||
-- fdWriteBuf will throw on error. Unless the error is EINTR. On EINTR the write will be retried.
|
||||
fdWriteAll :: Fd -> Ptr Word8 -> Int -> Int -> IO Int
|
||||
@ -99,10 +99,10 @@ sendCapToTerminal t cap capParams = do
|
||||
- terminfo does not support some features that would increase efficiency and improve compatibility:
|
||||
-
|
||||
- * determine the character encoding supported by the terminal. Should this be taken from the LANG
|
||||
- environment variable?
|
||||
- environment variable?
|
||||
-
|
||||
- * Provide independent string capabilities for all display attributes.
|
||||
-
|
||||
-
|
||||
- todo: Some display attributes like underline and bold have independent string capabilities that
|
||||
- should be used instead of the generic "sgr" string capability.
|
||||
-}
|
||||
@ -113,7 +113,7 @@ reserveTerminal termName outFd = liftIO $ do
|
||||
-- if set foreground is not set then all color changing style attributes are filtered.
|
||||
msetaf <- probeCap ti "setaf"
|
||||
msetf <- probeCap ti "setf"
|
||||
let (noColors, useAlt, setForeCap)
|
||||
let (noColors, useAlt, setForeCap)
|
||||
= case msetaf of
|
||||
Just setaf -> (False, False, setaf)
|
||||
Nothing -> case msetf of
|
||||
@ -121,7 +121,7 @@ reserveTerminal termName outFd = liftIO $ do
|
||||
Nothing -> (True, True, error $ "no fore color support for terminal " ++ termName)
|
||||
msetab <- probeCap ti "setab"
|
||||
msetb <- probeCap ti "setb"
|
||||
let set_back_cap
|
||||
let set_back_cap
|
||||
= case msetab of
|
||||
Nothing -> case msetb of
|
||||
Just setb -> setb
|
||||
@ -190,13 +190,13 @@ reserveTerminal termName outFd = liftIO $ do
|
||||
return t
|
||||
|
||||
requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression
|
||||
requireCap ti capName
|
||||
requireCap ti capName
|
||||
= case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
|
||||
Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""
|
||||
Just capStr -> parseCap capStr
|
||||
|
||||
probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)
|
||||
probeCap ti capName
|
||||
probeCap ti capName
|
||||
= case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of
|
||||
Nothing -> return Nothing
|
||||
Just capStr -> Just <$> parseCap capStr
|
||||
@ -207,11 +207,11 @@ parseCap capStr = do
|
||||
Left e -> fail $ show e
|
||||
Right cap -> return cap
|
||||
|
||||
currentDisplayAttrCaps :: ( Applicative m, MonadIO m )
|
||||
=> Terminfo.Terminal
|
||||
currentDisplayAttrCaps :: ( Applicative m, MonadIO m )
|
||||
=> Terminfo.Terminal
|
||||
-> m DisplayAttrCaps
|
||||
currentDisplayAttrCaps ti
|
||||
= pure DisplayAttrCaps
|
||||
currentDisplayAttrCaps ti
|
||||
= pure DisplayAttrCaps
|
||||
<*> probeCap ti "sgr"
|
||||
<*> probeCap ti "smso"
|
||||
<*> probeCap ti "rmso"
|
||||
@ -224,7 +224,7 @@ currentDisplayAttrCaps ti
|
||||
foreign import ccall "gwinsz.h vty_c_get_window_size" c_getWindowSize :: Fd -> IO CLong
|
||||
|
||||
getWindowSize :: Fd -> IO (Int,Int)
|
||||
getWindowSize fd = do
|
||||
getWindowSize fd = do
|
||||
(a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd
|
||||
return (fromIntegral b, fromIntegral a)
|
||||
|
||||
@ -249,14 +249,14 @@ terminfoDisplayContext tActual terminfoCaps r = return dc
|
||||
-- | Portably setting the display attributes is a giant pain in the ass.
|
||||
--
|
||||
-- If the terminal supports the sgr capability (which sets the on/off state of each style
|
||||
-- directly ; and, for no good reason, resets the colors to the default) this procedure is used:
|
||||
-- directly ; and, for no good reason, resets the colors to the default) this procedure is used:
|
||||
--
|
||||
-- 0. set the style attributes. This resets the fore and back color.
|
||||
--
|
||||
-- 1, If a foreground color is to be set then set the foreground color
|
||||
--
|
||||
-- 2. likewise with the background color
|
||||
--
|
||||
--
|
||||
-- If the terminal does not support the sgr cap then:
|
||||
-- if there is a change from an applied color to the default (in either the fore or back color)
|
||||
-- then:
|
||||
@ -290,13 +290,13 @@ terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
|
||||
(styleToApplySeq $ fixedStyle attr) of
|
||||
-- only way to reset a color to the defaults
|
||||
EnterExitSeq caps -> writeDefaultAttr dc
|
||||
`mappend`
|
||||
`mappend`
|
||||
foldMap (\cap -> writeCapExpr cap []) caps
|
||||
`mappend`
|
||||
setColors
|
||||
-- implicitly resets the colors to the defaults
|
||||
SetState state -> writeCapExpr (fromJust $ setAttrStates
|
||||
$ displayAttrCaps
|
||||
SetState state -> writeCapExpr (fromJust $ setAttrStates
|
||||
$ displayAttrCaps
|
||||
$ terminfoCaps
|
||||
)
|
||||
(sgrArgsForState state)
|
||||
@ -320,12 +320,12 @@ terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do
|
||||
`mappend`
|
||||
writeColorDiff setBackColor (backColorDiff diffs)
|
||||
-- implicitly resets the colors to the defaults
|
||||
SetState state -> writeCapExpr (fromJust $ setAttrStates
|
||||
SetState state -> writeCapExpr (fromJust $ setAttrStates
|
||||
$ displayAttrCaps terminfoCaps
|
||||
)
|
||||
(sgrArgsForState state)
|
||||
`mappend` setColors
|
||||
where
|
||||
where
|
||||
colorMap = case useAltColorMap terminfoCaps of
|
||||
False -> ansiColorIndex
|
||||
True -> altColorIndex
|
||||
@ -357,7 +357,7 @@ ansiColorIndex (ISOColor v) = fromEnum v
|
||||
ansiColorIndex (Color240 v) = 16 + fromEnum v
|
||||
|
||||
-- | For terminals without setaf/setab
|
||||
--
|
||||
--
|
||||
-- See table in `man terminfo`
|
||||
-- Will error if not in table.
|
||||
altColorIndex :: Color -> Int
|
||||
@ -375,7 +375,7 @@ altColorIndex (Color240 v) = 16 + fromEnum v
|
||||
{- | The sequence of terminfo caps to apply a given style are determined according to these rules.
|
||||
-
|
||||
- 1. The assumption is that it's preferable to use the simpler enter/exit mode capabilities than
|
||||
- the full set display attribute state capability.
|
||||
- the full set display attribute state capability.
|
||||
-
|
||||
- 2. If a mode is supposed to be removed but there is not an exit capability defined then the
|
||||
- display attributes are reset to defaults then the display attribute state is set.
|
||||
@ -422,7 +422,7 @@ reqDisplayCapSeqFor caps s diffs
|
||||
( False, _ ) -> EnterExitSeq $ map enterExitCap diffs
|
||||
-- If not all the diffs have an enter-exit cap and there is no set state cap then filter out
|
||||
-- all unsupported diffs and just apply the rest
|
||||
( True, False ) -> EnterExitSeq $ map enterExitCap
|
||||
( True, False ) -> EnterExitSeq $ map enterExitCap
|
||||
$ filter (not . noEnterExitCap) diffs
|
||||
-- if not all the diffs have an enter-exit can and there is a set state cap then just use
|
||||
-- the set state cap.
|
||||
@ -469,9 +469,8 @@ styleToApplySeq s = concat
|
||||
, applyIfRequired ApplyDim dim
|
||||
, applyIfRequired ApplyBlink bold
|
||||
]
|
||||
where
|
||||
applyIfRequired op flag
|
||||
where
|
||||
applyIfRequired op flag
|
||||
= if 0 == (flag .&. s)
|
||||
then []
|
||||
else [op]
|
||||
|
||||
|
||||
@ -32,7 +32,7 @@ import Data.List (isInfixOf)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Monoid ((<>))
|
||||
|
||||
-- | Initialize the display to UTF-8.
|
||||
-- | Initialize the display to UTF-8.
|
||||
reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Fd -> m Output
|
||||
reserveTerminal variant outFd = liftIO $ do
|
||||
let flushedPut = void . fdWrite outFd
|
||||
@ -112,4 +112,3 @@ xtermInlineHack :: Output -> IO ()
|
||||
xtermInlineHack t = do
|
||||
let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"
|
||||
outputByteBuffer t $ writeToByteString writeReset
|
||||
|
||||
|
||||
@ -11,7 +11,7 @@ import Graphics.Vty.Image
|
||||
|
||||
import Control.DeepSeq
|
||||
|
||||
-- | The type of images to be displayed using 'update'.
|
||||
-- | The type of images to be displayed using 'update'.
|
||||
--
|
||||
-- Can be constructed directly or using `picForImage`. Which provides an initial instance with
|
||||
-- reasonable defaults for picCursor and picBackground.
|
||||
@ -42,7 +42,7 @@ addToBottom p i = p {picLayers = picLayers p ++ [i]}
|
||||
-- | Create a picture for display for the given image. The picture will not have a displayed cursor
|
||||
-- and no background pattern (ClearBackground) will be used.
|
||||
picForImage :: Image -> Picture
|
||||
picForImage i = Picture
|
||||
picForImage i = Picture
|
||||
{ picCursor = NoCursor
|
||||
, picLayers = [i]
|
||||
, picBackground = ClearBackground
|
||||
@ -52,17 +52,17 @@ picForImage i = Picture
|
||||
--
|
||||
-- The picture will not have a displayed cursor and no background apttern (ClearBackgroun) will be
|
||||
-- used.
|
||||
--
|
||||
--
|
||||
-- The first 'Image' is the top layer.
|
||||
picForLayers :: [Image] -> Picture
|
||||
picForLayers is = Picture
|
||||
picForLayers is = Picture
|
||||
{ picCursor = NoCursor
|
||||
, picLayers = is
|
||||
, picBackground = ClearBackground
|
||||
}
|
||||
|
||||
-- | A picture can be configured either to not show the cursor or show the cursor at the specified
|
||||
-- character position.
|
||||
-- character position.
|
||||
--
|
||||
-- There is not a 1 to 1 map from character positions to a row and column on the screen due to
|
||||
-- characters that take more than 1 column.
|
||||
|
||||
@ -200,7 +200,7 @@ buildSpans image outRegion = do
|
||||
outOps <- MVector.replicate (regionHeight outRegion) Vector.empty
|
||||
-- \todo I think building the span operations in display order would provide better performance.
|
||||
-- However, I got stuck trying to implement an algorithm that did this. This will be considered
|
||||
-- as a possible future optimization.
|
||||
-- as a possible future optimization.
|
||||
--
|
||||
-- A depth first traversal of the image is performed. ordered according to the column range
|
||||
-- defined by the image from least to greatest. The output row ops will at least have the
|
||||
@ -208,7 +208,7 @@ buildSpans image outRegion = do
|
||||
-- all unspecified columns.
|
||||
--
|
||||
-- The images are made into span operations from left to right. It's possible that this could
|
||||
-- easily be made to assure top to bottom output as well.
|
||||
-- easily be made to assure top to bottom output as well.
|
||||
when (regionHeight outRegion > 0 && regionWidth outRegion > 0) $ do
|
||||
-- The ops builder recursively descends the image and outputs span ops that would
|
||||
-- display that image. The number of columns remaining in this row before exceeding the
|
||||
@ -297,7 +297,7 @@ addMaybeClipped CropTop {croppedImage, topSkip} = do
|
||||
skipRows += topSkip
|
||||
addMaybeClipped croppedImage
|
||||
|
||||
addMaybeClippedJoin :: forall s . String
|
||||
addMaybeClippedJoin :: forall s . String
|
||||
-> Lens BlitState BlitState Int Int
|
||||
-> Lens BlitState BlitState Int Int
|
||||
-> Lens BlitState BlitState Int Int
|
||||
@ -312,7 +312,7 @@ addMaybeClippedJoin name skip remaining offset i0Dim i0 i1 size = do
|
||||
case state^.skip of
|
||||
s -- TODO: check if clipped in other dim. if not use addUnclipped
|
||||
| s > size -> put $ state & skip -~ size
|
||||
| s == 0 -> if state^.remaining > i0Dim
|
||||
| s == 0 -> if state^.remaining > i0Dim
|
||||
then do
|
||||
addMaybeClipped i0
|
||||
put $ state & offset +~ i0Dim & remaining -~ i0Dim
|
||||
|
||||
@ -31,7 +31,7 @@ data SpanOp =
|
||||
-- | a span of UTF-8 text occupies a specific number of screen space columns. A single UTF
|
||||
-- character does not necessarially represent 1 colunm. See Codec.Binary.UTF8.Width
|
||||
-- TextSpan [Attr] [output width in columns] [number of characters] [data]
|
||||
TextSpan
|
||||
TextSpan
|
||||
{ textSpanAttr :: !Attr
|
||||
, textSpanOutputWidth :: !Int
|
||||
, textSpanCharWidth :: !Int
|
||||
@ -89,7 +89,6 @@ splitOpsAt inW inOps = splitOpsAt' inW inOps
|
||||
, Vector.cons (Skip (w - remainingColumns)) (Vector.tail ops)
|
||||
)
|
||||
RowEnd _ -> error "cannot split ops containing a row end"
|
||||
|
||||
|
||||
-- | vector of span operation vectors for display. One per row of the output region.
|
||||
type DisplayOps = Vector SpanOps
|
||||
@ -103,7 +102,7 @@ instance Show SpanOp where
|
||||
--
|
||||
-- All spans are verified to define same number of columns. See: VerifySpanOps
|
||||
displayOpsColumns :: DisplayOps -> Int
|
||||
displayOpsColumns ops
|
||||
displayOpsColumns ops
|
||||
| Vector.length ops == 0 = 0
|
||||
| otherwise = Vector.length $ Vector.head ops
|
||||
|
||||
@ -117,7 +116,7 @@ effectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)
|
||||
-- | The number of columns a SpanOps effects.
|
||||
spanOpsEffectedColumns :: SpanOps -> Int
|
||||
spanOpsEffectedColumns inOps = Vector.foldl' spanOpsEffectedColumns' 0 inOps
|
||||
where
|
||||
where
|
||||
spanOpsEffectedColumns' t (TextSpan _ w _ _ ) = t + w
|
||||
spanOpsEffectedColumns' t (Skip w) = t + w
|
||||
spanOpsEffectedColumns' t (RowEnd w) = t + w
|
||||
@ -135,4 +134,3 @@ columnsToCharOffset cx (TextSpan _ _ _ utf8Str) =
|
||||
in wcswidth (take cx str)
|
||||
columnsToCharOffset cx (Skip _) = cx
|
||||
columnsToCharOffset cx (RowEnd _) = cx
|
||||
|
||||
|
||||
@ -16,7 +16,7 @@ import System.Environment( getArgs )
|
||||
import System.IO
|
||||
import System.Random
|
||||
|
||||
bench0 = do
|
||||
bench0 = do
|
||||
let fixedGen = mkStdGen 0
|
||||
setStdGen fixedGen
|
||||
vty <- mkVty def
|
||||
@ -29,7 +29,7 @@ bench0 = do
|
||||
shutdown vty
|
||||
return $ Bench images bench
|
||||
|
||||
flipOut vty n image0 image1 =
|
||||
flipOut vty n image0 image1 =
|
||||
let !pLeft = picForImage image0
|
||||
!pRight = picForImage image1
|
||||
wLeft 0 = return ()
|
||||
|
||||
@ -23,7 +23,7 @@ bench0 = do
|
||||
shutdown vty
|
||||
return $ Bench testChars bench
|
||||
|
||||
testImageUsingChar c w h
|
||||
testImageUsingChar c w h
|
||||
= vertCat $ replicate (fromIntegral h)
|
||||
$ horizCat $ map (char defAttr) (replicate (fromIntegral w) c)
|
||||
|
||||
|
||||
@ -14,7 +14,7 @@ import System.Environment( getArgs )
|
||||
import System.IO
|
||||
import System.Random
|
||||
|
||||
bench0 = do
|
||||
bench0 = do
|
||||
let fixedGen = mkStdGen 0
|
||||
setStdGen fixedGen
|
||||
return $ Bench (return ()) (\() -> mkVty def >>= liftM2 (>>) run shutdown)
|
||||
@ -49,13 +49,12 @@ pad :: Int -> Image -> Image
|
||||
pad ml img = img <|> charFill defAttr ' ' (ml - imageWidth img) 1
|
||||
|
||||
clines :: StdGen -> Int -> [Image]
|
||||
clines g maxll = map (pad maxll . horizCat . map (uncurry string))
|
||||
clines g maxll = map (pad maxll . horizCat . map (uncurry string))
|
||||
$ fold (length . snd) (lengths maxll g1) (nums g2)
|
||||
where (g1,g2) = split g
|
||||
|
||||
benchgen :: DisplayRegion -> [Picture]
|
||||
benchgen (w,h)
|
||||
benchgen (w,h)
|
||||
= take 2000 $ map ((\i -> picForImage i) . vertCat . take (fromEnum h))
|
||||
$ tails
|
||||
$ clines (mkStdGen 80) w
|
||||
|
||||
|
||||
@ -5,7 +5,7 @@ import Graphics.Vty.ControlStrings
|
||||
import System.Console.Terminfo
|
||||
|
||||
main = do
|
||||
terminal <- setupTermFromEnv
|
||||
terminal <- setupTermFromEnv
|
||||
controlTable <- init_controlTable terminal
|
||||
putStrLn $ "ANSI terminal show cursor string: " ++ show cvis
|
||||
putStrLn $ "Current terminal show cursor string: " ++ show (showCursorStr controlTable)
|
||||
|
||||
@ -13,8 +13,8 @@ main = do
|
||||
play vty sx sy
|
||||
|
||||
play :: Vty -> Int -> Int -> IO ()
|
||||
play vty sx sy =
|
||||
let
|
||||
play vty sx sy =
|
||||
let
|
||||
testScreen = pic {
|
||||
pCursor = NoCursor
|
||||
, pImage = box 10 10 }
|
||||
@ -31,6 +31,5 @@ box w h =
|
||||
vertLine = renderFill attr '|' 1 (h - 2)
|
||||
horizLine = corner <|> renderHFill attr '-' (w - 2) <|> corner
|
||||
centerArea = vertLine <|> renderFill attr 'X' (w - 2) (h - 2) <|> vertLine
|
||||
in
|
||||
in
|
||||
horizLine <-> centerArea <-> horizLine
|
||||
|
||||
|
||||
@ -45,7 +45,7 @@ all : $(VERIF_TESTS)
|
||||
|
||||
.PHONY: $(TESTS)
|
||||
.SECONDEXPANSION:
|
||||
$(TESTS) :
|
||||
$(TESTS) :
|
||||
@echo running test $@
|
||||
@mkdir -p results/$@
|
||||
( ghc $(GHC_PROF_ARGS) $@ \
|
||||
@ -54,7 +54,7 @@ $(TESTS) :
|
||||
)
|
||||
|
||||
.PHONY: interactive_terminal_test
|
||||
interactive_terminal_test :
|
||||
interactive_terminal_test :
|
||||
ghc $(GHC_ARGS) $@ && ./$@
|
||||
|
||||
.PHONY: core
|
||||
|
||||
@ -35,7 +35,7 @@ import qualified Test.QuickCheck as QC
|
||||
import Test.QuickCheck.Modifiers
|
||||
import Test.QuickCheck.Property hiding ( Result(..) )
|
||||
import qualified Test.QuickCheck.Property as Prop
|
||||
import Test.QuickCheck.Monadic ( monadicIO )
|
||||
import Test.QuickCheck.Monadic ( monadicIO )
|
||||
|
||||
import Text.Printf
|
||||
|
||||
@ -56,7 +56,7 @@ verify testName p = Test $ TestInstance
|
||||
case qcResult of
|
||||
QC.Success {..} -> return $ Finished TS.Pass
|
||||
QC.Failure {numShrinks,reason} -> return $ Finished
|
||||
$ TS.Fail $ "After "
|
||||
$ TS.Fail $ "After "
|
||||
++ show numShrinks ++ " shrinks determined failure to be: "
|
||||
++ show reason
|
||||
_ -> return $ Finished $ TS.Fail "TODO(corey): add failure message"
|
||||
@ -87,7 +87,7 @@ liftIOResult = ioProperty
|
||||
|
||||
#if __GLASGOW_HASKELL__ <= 701
|
||||
instance Random Word where
|
||||
random g =
|
||||
random g =
|
||||
let (i :: Int, g') = random g
|
||||
in (toEnum i, g')
|
||||
randomR (l,h) g =
|
||||
@ -97,4 +97,3 @@ instance Random Word where
|
||||
|
||||
data Bench where
|
||||
Bench :: forall v . NFData v => IO v -> (v -> IO ()) -> Bench
|
||||
|
||||
|
||||
@ -19,22 +19,22 @@ data NonParamCapString = NonParamCapString String
|
||||
deriving Show
|
||||
|
||||
instance Arbitrary NonParamCapString where
|
||||
arbitrary
|
||||
arbitrary
|
||||
= ( do
|
||||
s <- listOf1 $ (choose (0, 255) >>= return . toEnum) `suchThat` (/= '%')
|
||||
return $ NonParamCapString s
|
||||
) `suchThat` ( \(NonParamCapString str) -> length str < 255 )
|
||||
) `suchThat` ( \(NonParamCapString str) -> length str < 255 )
|
||||
|
||||
data LiteralPercentCap = LiteralPercentCap String [Word8]
|
||||
deriving ( Show )
|
||||
|
||||
instance Arbitrary LiteralPercentCap where
|
||||
arbitrary
|
||||
arbitrary
|
||||
= ( do
|
||||
NonParamCapString s <- arbitrary
|
||||
(s', bytes) <- insertEscapeOp "%" [toEnum $ fromEnum '%'] s
|
||||
return $ LiteralPercentCap s' bytes
|
||||
) `suchThat` ( \(LiteralPercentCap str _) -> length str < 255 )
|
||||
) `suchThat` ( \(LiteralPercentCap str _) -> length str < 255 )
|
||||
|
||||
data IncFirstTwoCap = IncFirstTwoCap String [Word8]
|
||||
deriving ( Show )
|
||||
@ -45,7 +45,7 @@ instance Arbitrary IncFirstTwoCap where
|
||||
NonParamCapString s <- arbitrary
|
||||
(s', bytes) <- insertEscapeOp "i" [] s
|
||||
return $ IncFirstTwoCap s' bytes
|
||||
) `suchThat` ( \(IncFirstTwoCap str _) -> length str < 255 )
|
||||
) `suchThat` ( \(IncFirstTwoCap str _) -> length str < 255 )
|
||||
|
||||
data PushParamCap = PushParamCap String Int [Word8]
|
||||
deriving ( Show )
|
||||
@ -57,7 +57,7 @@ instance Arbitrary PushParamCap where
|
||||
n <- choose (1,9)
|
||||
(s', bytes) <- insertEscapeOp ("p" ++ show n) [] s
|
||||
return $ PushParamCap s' n bytes
|
||||
) `suchThat` ( \(PushParamCap str _ _) -> length str < 255 )
|
||||
) `suchThat` ( \(PushParamCap str _ _) -> length str < 255 )
|
||||
|
||||
data DecPrintCap = DecPrintCap String Int [Word8]
|
||||
deriving ( Show )
|
||||
@ -69,7 +69,7 @@ instance Arbitrary DecPrintCap where
|
||||
n <- choose (1,9)
|
||||
(s', bytes) <- insertEscapeOp ("p" ++ show n ++ "%d") [] s
|
||||
return $ DecPrintCap s' n bytes
|
||||
) `suchThat` ( \(DecPrintCap str _ _) -> length str < 255 )
|
||||
) `suchThat` ( \(DecPrintCap str _ _) -> length str < 255 )
|
||||
|
||||
insertEscapeOp opStr replBytes s = do
|
||||
insertPoints <- listOf1 $ elements [0 .. length s - 1]
|
||||
@ -92,21 +92,20 @@ bytesForRange cap offset count
|
||||
= Vector.toList $ Vector.take count $ Vector.drop offset $ capBytes cap
|
||||
|
||||
collectBytes :: CapExpression -> [Word8]
|
||||
collectBytes e = concat [ bytes
|
||||
collectBytes e = concat [ bytes
|
||||
| Bytes offset count <- capOps e
|
||||
, let bytes = bytesForRange e offset count
|
||||
]
|
||||
|
||||
|
||||
|
||||
verifyBytesEqual :: [Word8] -> [Word8] -> Result
|
||||
verifyBytesEqual outBytes expectedBytes
|
||||
verifyBytesEqual outBytes expectedBytes
|
||||
= if outBytes == expectedBytes
|
||||
then succeeded
|
||||
else failed
|
||||
{ reason = "outBytes ["
|
||||
else failed
|
||||
{ reason = "outBytes ["
|
||||
++ hexDump outBytes
|
||||
++ "] /= expectedBytes ["
|
||||
++ hexDump expectedBytes
|
||||
++ "]"
|
||||
}
|
||||
|
||||
|
||||
@ -40,8 +40,8 @@ allStyles =
|
||||
|
||||
-- Limit the possible attributes to just a few for now.
|
||||
possibleAttrMods :: [ AttrOp ]
|
||||
possibleAttrMods =
|
||||
[ idOp
|
||||
possibleAttrMods =
|
||||
[ idOp
|
||||
] ++ map setForeColorOp allColors
|
||||
++ map setBackColorOp allColors
|
||||
++ map setStyleOp allStyles
|
||||
@ -70,4 +70,3 @@ idOp = AttrOp "id" id
|
||||
|
||||
applyOp :: AttrOp -> Attr -> Attr
|
||||
applyOp (AttrOp _ f) a = f a
|
||||
|
||||
|
||||
@ -26,7 +26,7 @@ instance Show UnitImage where
|
||||
data DefaultImage = DefaultImage Image
|
||||
|
||||
instance Show DefaultImage where
|
||||
show (DefaultImage i)
|
||||
show (DefaultImage i)
|
||||
= "DefaultImage (" ++ show i ++ ") " ++ show (imageWidth i, imageHeight i)
|
||||
|
||||
instance Arbitrary DefaultImage where
|
||||
@ -34,15 +34,15 @@ instance Arbitrary DefaultImage where
|
||||
i <- return $ char defAttr 'X'
|
||||
return $ DefaultImage i
|
||||
|
||||
data SingleRowSingleAttrImage
|
||||
= SingleRowSingleAttrImage
|
||||
data SingleRowSingleAttrImage
|
||||
= SingleRowSingleAttrImage
|
||||
{ expectedAttr :: Attr
|
||||
, expectedColumns :: Int
|
||||
, rowImage :: Image
|
||||
}
|
||||
|
||||
instance Show SingleRowSingleAttrImage where
|
||||
show (SingleRowSingleAttrImage attr columns image)
|
||||
show (SingleRowSingleAttrImage attr columns image)
|
||||
= "SingleRowSingleAttrImage (" ++ show attr ++ ") " ++ show columns ++ " ( " ++ show image ++ " )"
|
||||
|
||||
newtype WidthResize = WidthResize (Image -> (Image, Int))
|
||||
@ -84,14 +84,14 @@ instance Arbitrary ImageResize where
|
||||
, do
|
||||
ImageResize f <- arbitrary
|
||||
WidthResize g <- arbitrary
|
||||
return $! ImageResize $! \i ->
|
||||
return $! ImageResize $! \i ->
|
||||
let (i0, (_, outHeight)) = f i
|
||||
gI = g i0
|
||||
in (fst gI, (snd gI, outHeight))
|
||||
, do
|
||||
ImageResize f <- arbitrary
|
||||
HeightResize g <- arbitrary
|
||||
return $! ImageResize $! \i ->
|
||||
return $! ImageResize $! \i ->
|
||||
let (i0, (outWidth, _)) = f i
|
||||
gI = g i0
|
||||
in (fst gI, (outWidth, snd gI))
|
||||
@ -109,8 +109,8 @@ instance Arbitrary SingleRowSingleAttrImage where
|
||||
outWidth = length singleColumnRowText
|
||||
return $ SingleRowSingleAttrImage a outWidth outImage
|
||||
|
||||
data SingleRowTwoAttrImage
|
||||
= SingleRowTwoAttrImage
|
||||
data SingleRowTwoAttrImage
|
||||
= SingleRowTwoAttrImage
|
||||
{ part0 :: SingleRowSingleAttrImage
|
||||
, part1 :: SingleRowSingleAttrImage
|
||||
, joinImage :: Image
|
||||
@ -122,8 +122,8 @@ instance Arbitrary SingleRowTwoAttrImage where
|
||||
p1 <- arbitrary
|
||||
return $ SingleRowTwoAttrImage p0 p1 (rowImage p0 <|> rowImage p1)
|
||||
|
||||
data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack
|
||||
{ stackImage :: Image
|
||||
data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack
|
||||
{ stackImage :: Image
|
||||
, stackSourceImages :: [SingleRowSingleAttrImage]
|
||||
, stackWidth :: Int
|
||||
, stackHeight :: Int
|
||||
@ -215,4 +215,3 @@ instance Arbitrary Translation where
|
||||
y <- arbitrary `suchThat` (> 0)
|
||||
let i' = translate x y i
|
||||
return $ Translation i (x,y) i'
|
||||
|
||||
|
||||
@ -15,7 +15,7 @@ import Test.QuickCheck.Property
|
||||
-- not be supported were removed. Then a few more were pruned until a reasonable looking set was
|
||||
-- made.
|
||||
terminalsOfInterest :: [String]
|
||||
terminalsOfInterest =
|
||||
terminalsOfInterest =
|
||||
[ "vt100"
|
||||
, "vt220"
|
||||
, "vt102"
|
||||
@ -58,4 +58,3 @@ compareMockOutput mockData expectedStr = do
|
||||
++ expectedStr
|
||||
}
|
||||
else return succeeded
|
||||
|
||||
|
||||
@ -14,9 +14,9 @@ import Verify.Graphics.Vty.Image
|
||||
|
||||
import Verify
|
||||
|
||||
data DefaultPic = DefaultPic
|
||||
data DefaultPic = DefaultPic
|
||||
{ defaultPic :: Picture
|
||||
, defaultWin :: MockWindow
|
||||
, defaultWin :: MockWindow
|
||||
}
|
||||
|
||||
instance Show DefaultPic where
|
||||
@ -27,10 +27,10 @@ instance Arbitrary DefaultPic where
|
||||
arbitrary = do
|
||||
DefaultImage image <- arbitrary
|
||||
let win = MockWindow (imageWidth image) (imageHeight image)
|
||||
return $ DefaultPic (picForImage image)
|
||||
win
|
||||
return $ DefaultPic (picForImage image)
|
||||
win
|
||||
|
||||
data PicWithBGAttr = PicWithBGAttr
|
||||
data PicWithBGAttr = PicWithBGAttr
|
||||
{ withAttrPic :: Picture
|
||||
, withAttrWin :: MockWindow
|
||||
, withAttrSpecifiedAttr :: Attr
|
||||
@ -41,12 +41,11 @@ instance Arbitrary PicWithBGAttr where
|
||||
DefaultImage image <- arbitrary
|
||||
let win = MockWindow (imageWidth image) (imageHeight image)
|
||||
attr <- arbitrary
|
||||
return $ PicWithBGAttr (picForImage image)
|
||||
win
|
||||
return $ PicWithBGAttr (picForImage image)
|
||||
win
|
||||
attr
|
||||
|
||||
|
||||
instance Arbitrary Picture where
|
||||
arbitrary = do
|
||||
layers <- Verify.resize 20 (listOf1 arbitrary)
|
||||
return $ picForLayers layers
|
||||
|
||||
|
||||
@ -22,7 +22,7 @@ verifyAllSpansHaveWidth i spans w
|
||||
= let v = map (\s -> (spanOpsEffectedColumns s /= w, s)) (Vector.toList spans)
|
||||
in case any ((== True) . fst) v of
|
||||
False -> succeeded
|
||||
True -> failed { reason = "Not all spans contained operations defining exactly "
|
||||
True -> failed { reason = "Not all spans contained operations defining exactly "
|
||||
++ show w
|
||||
++ " columns of output - \n"
|
||||
++ (concatMap ((++ "\n") . show)) v
|
||||
@ -34,4 +34,3 @@ verifyOpsEquality i_ops i_alt_ops =
|
||||
else failed { reason = "ops for alternate image " ++ show i_alt_ops
|
||||
++ " are not the same as " ++ show i_ops
|
||||
}
|
||||
|
||||
|
||||
@ -13,7 +13,7 @@ import Graphics.Vty.PictureToSpans
|
||||
|
||||
import Verify
|
||||
|
||||
import qualified Data.Vector as Vector
|
||||
import qualified Data.Vector as Vector
|
||||
|
||||
cropOpDisplayOps :: (Int -> Image -> Image) ->
|
||||
Int -> Image -> (DisplayOps, Image)
|
||||
@ -75,7 +75,7 @@ cropTopAndBottomRejoinedEquivalence stack = imageHeight (stackImage stack) `mod`
|
||||
in displayOpsForImage i == displayOpsForImage iAlt
|
||||
|
||||
tests :: IO [Test]
|
||||
tests = return
|
||||
tests = return
|
||||
[ verify "cropping from the bottom produces display operations covering the expected rows"
|
||||
cropBottomOutputRows
|
||||
, verify "cropping from the top produces display operations covering the expected rows"
|
||||
@ -90,4 +90,3 @@ tests = return
|
||||
, verify "the output of a stack is the same as that stack cropped top & bottom and joined together"
|
||||
cropTopAndBottomRejoinedEquivalence
|
||||
]
|
||||
|
||||
|
||||
@ -3,7 +3,7 @@
|
||||
module VerifyEvalTerminfoCaps where
|
||||
|
||||
import Blaze.ByteString.Builder.Internal.Write (runWrite, getBound)
|
||||
import Data.Terminfo.Eval
|
||||
import Data.Terminfo.Eval
|
||||
import Data.Terminfo.Parse
|
||||
import Control.DeepSeq
|
||||
|
||||
@ -25,7 +25,7 @@ import Foreign.Ptr (Ptr, minusPtr)
|
||||
import Numeric
|
||||
|
||||
-- If a terminal defines one of the caps then it's expected to be parsable.
|
||||
capsOfInterest =
|
||||
capsOfInterest =
|
||||
[ "cup"
|
||||
, "sc"
|
||||
, "rc"
|
||||
@ -54,7 +54,7 @@ tests = do
|
||||
putStrLn $ "adding tests for terminal: " ++ termName
|
||||
mti <- try $ Terminfo.setupTerm termName
|
||||
case mti of
|
||||
Left (_e :: SomeException)
|
||||
Left (_e :: SomeException)
|
||||
-> return []
|
||||
Right ti -> do
|
||||
fmap concat $ forM capsOfInterest $ \capName -> do
|
||||
@ -71,7 +71,7 @@ tests = do
|
||||
{-# NOINLINE verifyEvalCap #-}
|
||||
verifyEvalCap :: Ptr Word8 -> CapExpression -> Int -> Property
|
||||
verifyEvalCap evalBuffer expr !junkInt = do
|
||||
forAll (vector 9) $ \inputValues ->
|
||||
forAll (vector 9) $ \inputValues ->
|
||||
let write = writeCapExpr expr inputValues
|
||||
!byteCount = getBound write
|
||||
in liftIOResult $ do
|
||||
@ -79,12 +79,12 @@ verifyEvalCap evalBuffer expr !junkInt = do
|
||||
forM_ [0..100] $ \i -> runWrite write startPtr
|
||||
endPtr <- runWrite write startPtr
|
||||
case endPtr `minusPtr` startPtr of
|
||||
count | count < 0 ->
|
||||
count | count < 0 ->
|
||||
return $ failed { reason = "End pointer before start pointer." }
|
||||
| toEnum count > byteCount ->
|
||||
return $ failed { reason = "End pointer past end of buffer by "
|
||||
++ show (toEnum count - byteCount)
|
||||
| toEnum count > byteCount ->
|
||||
return $ failed { reason = "End pointer past end of buffer by "
|
||||
++ show (toEnum count - byteCount)
|
||||
}
|
||||
| otherwise ->
|
||||
| otherwise ->
|
||||
return succeeded
|
||||
|
||||
|
||||
@ -9,43 +9,43 @@ import Verify
|
||||
import Control.DeepSeq
|
||||
|
||||
twoSwHorizConcat :: SingleColumnChar -> SingleColumnChar -> Bool
|
||||
twoSwHorizConcat (SingleColumnChar c1) (SingleColumnChar c2) =
|
||||
twoSwHorizConcat (SingleColumnChar c1) (SingleColumnChar c2) =
|
||||
imageWidth (char defAttr c1 <|> char defAttr c2) == 2
|
||||
|
||||
manySwHorizConcat :: [SingleColumnChar] -> Bool
|
||||
manySwHorizConcat cs =
|
||||
manySwHorizConcat cs =
|
||||
let chars = [ char | SingleColumnChar char <- cs ]
|
||||
l = fromIntegral $ length cs
|
||||
in imageWidth ( horizCat $ map (char defAttr) chars ) == l
|
||||
|
||||
twoSwVertConcat :: SingleColumnChar -> SingleColumnChar -> Bool
|
||||
twoSwVertConcat (SingleColumnChar c1) (SingleColumnChar c2) =
|
||||
twoSwVertConcat (SingleColumnChar c1) (SingleColumnChar c2) =
|
||||
imageHeight (char defAttr c1 <-> char defAttr c2) == 2
|
||||
|
||||
horizConcatSwAssoc :: SingleColumnChar -> SingleColumnChar -> SingleColumnChar -> Bool
|
||||
horizConcatSwAssoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) =
|
||||
(char defAttr c0 <|> char defAttr c1) <|> char defAttr c2
|
||||
==
|
||||
horizConcatSwAssoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) =
|
||||
(char defAttr c0 <|> char defAttr c1) <|> char defAttr c2
|
||||
==
|
||||
char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2)
|
||||
|
||||
twoDwHorizConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool
|
||||
twoDwHorizConcat (DoubleColumnChar c1) (DoubleColumnChar c2) =
|
||||
twoDwHorizConcat (DoubleColumnChar c1) (DoubleColumnChar c2) =
|
||||
imageWidth (char defAttr c1 <|> char defAttr c2) == 4
|
||||
|
||||
manyDwHorizConcat :: [DoubleColumnChar] -> Bool
|
||||
manyDwHorizConcat cs =
|
||||
manyDwHorizConcat cs =
|
||||
let chars = [ char | DoubleColumnChar char <- cs ]
|
||||
l = fromIntegral $ length cs
|
||||
in imageWidth ( horizCat $ map (char defAttr) chars ) == l * 2
|
||||
|
||||
twoDwVertConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool
|
||||
twoDwVertConcat (DoubleColumnChar c1) (DoubleColumnChar c2) =
|
||||
twoDwVertConcat (DoubleColumnChar c1) (DoubleColumnChar c2) =
|
||||
imageHeight (char defAttr c1 <-> char defAttr c2) == 2
|
||||
|
||||
horizConcatDwAssoc :: DoubleColumnChar -> DoubleColumnChar -> DoubleColumnChar -> Bool
|
||||
horizConcatDwAssoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) =
|
||||
(char defAttr c0 <|> char defAttr c1) <|> char defAttr c2
|
||||
==
|
||||
horizConcatDwAssoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) =
|
||||
(char defAttr c0 <|> char defAttr c1) <|> char defAttr c2
|
||||
==
|
||||
char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2)
|
||||
|
||||
vertContatSingleRow :: NonEmptyList SingleRowSingleAttrImage -> Bool
|
||||
@ -54,9 +54,9 @@ vertContatSingleRow (NonEmpty stack) =
|
||||
stackImage = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack ]
|
||||
in imageHeight stackImage == expectedHeight
|
||||
|
||||
disjointHeightHorizJoin :: NonEmptyList SingleRowSingleAttrImage
|
||||
-> NonEmptyList SingleRowSingleAttrImage
|
||||
-> Bool
|
||||
disjointHeightHorizJoin :: NonEmptyList SingleRowSingleAttrImage
|
||||
-> NonEmptyList SingleRowSingleAttrImage
|
||||
-> Bool
|
||||
disjointHeightHorizJoin (NonEmpty stack0) (NonEmpty stack1) =
|
||||
let expectedHeight :: Int = max (length stack0) (length stack1)
|
||||
stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]
|
||||
@ -64,9 +64,9 @@ disjointHeightHorizJoin (NonEmpty stack0) (NonEmpty stack1) =
|
||||
in imageHeight (stackImage0 <|> stackImage1) == expectedHeight
|
||||
|
||||
|
||||
disjointHeightHorizJoinBgFill :: NonEmptyList SingleRowSingleAttrImage
|
||||
-> NonEmptyList SingleRowSingleAttrImage
|
||||
-> Bool
|
||||
disjointHeightHorizJoinBgFill :: NonEmptyList SingleRowSingleAttrImage
|
||||
-> NonEmptyList SingleRowSingleAttrImage
|
||||
-> Bool
|
||||
disjointHeightHorizJoinBgFill (NonEmpty stack0) (NonEmpty stack1) =
|
||||
let stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]
|
||||
stackImage1 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]
|
||||
@ -74,31 +74,31 @@ disjointHeightHorizJoinBgFill (NonEmpty stack0) (NonEmpty stack1) =
|
||||
expectedHeight = imageHeight image
|
||||
in case image of
|
||||
HorizJoin {} -> ( expectedHeight == (imageHeight $ partLeft image) )
|
||||
&&
|
||||
&&
|
||||
( expectedHeight == (imageHeight $ partRight image) )
|
||||
_ -> True
|
||||
|
||||
disjointWidthVertJoin :: NonEmptyList SingleRowSingleAttrImage
|
||||
disjointWidthVertJoin :: NonEmptyList SingleRowSingleAttrImage
|
||||
-> NonEmptyList SingleRowSingleAttrImage
|
||||
-> Bool
|
||||
disjointWidthVertJoin (NonEmpty stack0) (NonEmpty stack1) =
|
||||
let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images)
|
||||
stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]
|
||||
stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]
|
||||
stack0Image = vertCat stack0Images
|
||||
stack1Image = vertCat stack1Images
|
||||
stack0Image = vertCat stack0Images
|
||||
stack1Image = vertCat stack1Images
|
||||
image = stack0Image <-> stack1Image
|
||||
in imageWidth image == expectedWidth
|
||||
|
||||
disjointWidthVertJoinBgFill :: NonEmptyList SingleRowSingleAttrImage
|
||||
disjointWidthVertJoinBgFill :: NonEmptyList SingleRowSingleAttrImage
|
||||
-> NonEmptyList SingleRowSingleAttrImage
|
||||
-> Bool
|
||||
disjointWidthVertJoinBgFill (NonEmpty stack0) (NonEmpty stack1) =
|
||||
let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images)
|
||||
stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack0 ]
|
||||
stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack1 ]
|
||||
stack0Image = vertCat stack0Images
|
||||
stack1Image = vertCat stack1Images
|
||||
stack0Image = vertCat stack0Images
|
||||
stack1Image = vertCat stack1Images
|
||||
image = stack0Image <-> stack1Image
|
||||
in case image of
|
||||
VertJoin {} -> ( expectedWidth == (imageWidth $ partTop image) )
|
||||
@ -171,4 +171,3 @@ tests = return
|
||||
, verify "can rnf image" canRnfImage
|
||||
, verify "can pp image" canPpImage
|
||||
]
|
||||
|
||||
|
||||
@ -22,7 +22,7 @@ verifyHorizContatWAttrChangeSimplifies :: SingleRowTwoAttrImage -> Bool
|
||||
verifyHorizContatWAttrChangeSimplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 charCount0 _image0)
|
||||
(SingleRowSingleAttrImage attr1 charCount1 _image1)
|
||||
i
|
||||
)
|
||||
)
|
||||
| charCount0 == 0 || charCount1 == 0 || attr0 == attr1 = isHorizTextOfColumns i (charCount0 + charCount1)
|
||||
| otherwise = False == isHorizTextOfColumns i (charCount0 + charCount1)
|
||||
|
||||
|
||||
@ -13,7 +13,7 @@ import Graphics.Vty.PictureToSpans
|
||||
|
||||
import Verify
|
||||
|
||||
import qualified Data.Vector as Vector
|
||||
import qualified Data.Vector as Vector
|
||||
|
||||
largerHorizSpanOcclusion :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result
|
||||
largerHorizSpanOcclusion row0 row1 =
|
||||
@ -109,7 +109,7 @@ horizJoinAlternate1 =
|
||||
in verifyOpsEquality expectedOps opsLayered
|
||||
|
||||
tests :: IO [Test]
|
||||
tests = return
|
||||
tests = return
|
||||
[ verify "a larger horiz span occludes a smaller span on a lower layer"
|
||||
largerHorizSpanOcclusion
|
||||
, verify "two rows stack vertical equiv to first image layered on top of second with padding (0)"
|
||||
|
||||
@ -16,7 +16,7 @@ import Numeric
|
||||
|
||||
-- If a terminal defines one of the caps then it's expected to be parsable.
|
||||
-- TODO: reduce duplication with terminfo terminal implementation.
|
||||
capsOfInterest =
|
||||
capsOfInterest =
|
||||
[ "cup"
|
||||
, "sc"
|
||||
, "rc"
|
||||
@ -65,7 +65,7 @@ verifyParseCap capString onParse =
|
||||
Right e -> onParse e
|
||||
|
||||
nonParamaterizedCaps (NonParamCapString cap) = do
|
||||
verifyParseCap cap $ \e ->
|
||||
verifyParseCap cap $ \e ->
|
||||
let expectedBytes = map (toEnum . fromEnum) cap
|
||||
outBytes = bytesForRange e 0 (length cap)
|
||||
in verifyBytesEqual outBytes expectedBytes
|
||||
@ -75,7 +75,7 @@ literalPercentCaps (LiteralPercentCap capString expectedBytes) = do
|
||||
|
||||
incFirstTwoCaps (IncFirstTwoCap capString expectedBytes) = do
|
||||
verifyParseCap capString $ \e -> verifyBytesEqual (collectBytes e) expectedBytes
|
||||
|
||||
|
||||
pushParamCaps (PushParamCap capString expectedParamCount expectedBytes) = do
|
||||
verifyParseCap capString $ \e ->
|
||||
let outBytes = collectBytes e
|
||||
@ -98,4 +98,3 @@ printCap ti capName = do
|
||||
printExpression ti capName = do
|
||||
let parseResult = parseCapExpression $ fromCapname ti capName
|
||||
putStrLn $ capName ++ ": " ++ show parseResult
|
||||
|
||||
|
||||
@ -13,28 +13,28 @@ import Graphics.Vty.PictureToSpans
|
||||
|
||||
import Verify
|
||||
|
||||
import qualified Data.Vector as Vector
|
||||
import qualified Data.Vector as Vector
|
||||
|
||||
unitImageAndZeroWindow0 :: UnitImage -> EmptyWindow -> Bool
|
||||
unitImageAndZeroWindow0 (UnitImage _ i) (EmptyWindow w) =
|
||||
unitImageAndZeroWindow0 (UnitImage _ i) (EmptyWindow w) =
|
||||
let p = picForImage i
|
||||
ops = displayOpsForPic p (regionForWindow w)
|
||||
in displayOpsColumns ops == 0 && displayOpsRows ops == 0
|
||||
|
||||
unitImageAndZeroWindow1 :: UnitImage -> EmptyWindow -> Bool
|
||||
unitImageAndZeroWindow1 (UnitImage _ i) (EmptyWindow w) =
|
||||
unitImageAndZeroWindow1 (UnitImage _ i) (EmptyWindow w) =
|
||||
let p = picForImage i
|
||||
ops = displayOpsForPic p (regionForWindow w)
|
||||
in ( spanOpsEffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )
|
||||
|
||||
horizSpanImageAndZeroWindow0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool
|
||||
horizSpanImageAndZeroWindow0 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =
|
||||
horizSpanImageAndZeroWindow0 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =
|
||||
let p = picForImage i
|
||||
ops = displayOpsForPic p (regionForWindow w)
|
||||
in displayOpsColumns ops == 0 && displayOpsRows ops == 0
|
||||
|
||||
horizSpanImageAndZeroWindow1 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool
|
||||
horizSpanImageAndZeroWindow1 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =
|
||||
horizSpanImageAndZeroWindow1 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =
|
||||
let p = picForImage i
|
||||
ops = displayOpsForPic p (regionForWindow w)
|
||||
in ( spanOpsEffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )
|
||||
@ -139,7 +139,7 @@ spanOpsActuallyFillColumns (DefaultPic pic win) =
|
||||
in allSpansHaveWidth ops expectedColumnCount
|
||||
|
||||
firstSpanOpSetsAttr :: DefaultPic -> Bool
|
||||
firstSpanOpSetsAttr DefaultPic { defaultPic = pic, defaultWin = win } =
|
||||
firstSpanOpSetsAttr DefaultPic { defaultPic = pic, defaultWin = win } =
|
||||
let ops = displayOpsForPic pic (regionForWindow win)
|
||||
in all ( isAttrSpanOp . Vector.head ) ( Vector.toList ops )
|
||||
|
||||
@ -158,7 +158,7 @@ imageCoverageMatchesBounds i =
|
||||
in verifyAllSpansHaveWidth i ops (imageWidth i)
|
||||
|
||||
tests :: IO [Test]
|
||||
tests = return
|
||||
tests = return
|
||||
[ verify "unit image is cropped when window size == (0,0) [0]" unitImageAndZeroWindow0
|
||||
, verify "unit image is cropped when window size == (0,0) [1]" unitImageAndZeroWindow1
|
||||
, verify "horiz span image is cropped when window size == (0,0) [0]" horizSpanImageAndZeroWindow0
|
||||
@ -171,7 +171,7 @@ tests = return
|
||||
, verify "a stack of single attr text spans should define content for all the columns [output region == size of stack]"
|
||||
singleAttrSingleSpanStackOpCoverage
|
||||
, verify "a single attr text span is cropped when window size < size of stack image [width]"
|
||||
singleAttrSingleSpanStackCropped0
|
||||
singleAttrSingleSpanStackCropped0
|
||||
, verify "a single attr text span is cropped when window size < size of stack image [height]"
|
||||
singleAttrSingleSpanStackCropped1
|
||||
, verify "single attr text span <|> single attr text span display cropped. [width]"
|
||||
|
||||
@ -49,7 +49,7 @@ singleTRow (MockWindow w h) = liftIOResult $ do
|
||||
let expected = "H" ++ "MDA" ++ replicate (fromEnum w) 'T'
|
||||
++ concat (replicate (fromEnum h - 1) $ "MDA" ++ replicate (fromEnum w) 'B')
|
||||
compareMockOutput mockData expected
|
||||
|
||||
|
||||
manyTRows :: MockWindow -> Property
|
||||
manyTRows (MockWindow w h) = liftIOResult $ do
|
||||
(mockData, t) <- mockTerminal (w,h)
|
||||
|
||||
@ -19,7 +19,7 @@ import Data.Monoid
|
||||
import Data.String.QQ
|
||||
import Data.Word
|
||||
|
||||
import Foreign.Marshal.Array
|
||||
import Foreign.Marshal.Array
|
||||
|
||||
import qualified System.Environment as Env
|
||||
|
||||
@ -74,12 +74,12 @@ with the test_results.list file pasted into the issue. A suitable summary is:
|
||||
|]
|
||||
waitForReturn
|
||||
results <- doTestMenu 1
|
||||
envAttributes <- mapM ( \envName -> Control.Exception.catch ( Env.getEnv envName >>= return . (,) envName )
|
||||
( \ (_ :: SomeException) -> return (envName, "") )
|
||||
)
|
||||
envAttributes <- mapM ( \envName -> Control.Exception.catch ( Env.getEnv envName >>= return . (,) envName )
|
||||
( \ (_ :: SomeException) -> return (envName, "") )
|
||||
)
|
||||
[ "TERM", "COLORTERM", "LANG", "TERM_PROGRAM", "XTERM_VERSION" ]
|
||||
t <- standardIOConfig >>= outputForConfig
|
||||
let resultsTxt = show envAttributes ++ "\n"
|
||||
let resultsTxt = show envAttributes ++ "\n"
|
||||
++ terminalID t ++ "\n"
|
||||
++ show results ++ "\n"
|
||||
releaseTerminal t
|
||||
@ -94,7 +94,7 @@ testMenu :: [(String, Test)]
|
||||
testMenu = zip (map show [1..]) allTests
|
||||
|
||||
doTestMenu :: Int -> IO [(String, Bool)]
|
||||
doTestMenu nextID
|
||||
doTestMenu nextID
|
||||
| nextID > length allTests = do
|
||||
putStrLn $ "Done! Please email the " ++ outputFilePath ++ " file to coreyoconnor@gmail.com"
|
||||
return []
|
||||
@ -108,26 +108,26 @@ doTestMenu nextID
|
||||
s <- getLine >>= return . filter (/= '\n')
|
||||
case s of
|
||||
"q" -> return mempty
|
||||
"" -> do
|
||||
r <- runTest $ show nextID
|
||||
"" -> do
|
||||
r <- runTest $ show nextID
|
||||
rs <- doTestMenu ( nextID + 1 )
|
||||
return $ r : rs
|
||||
i | isJust ( lookup i testMenu ) -> do
|
||||
r <- runTest i
|
||||
r <- runTest i
|
||||
rs <- doTestMenu ( read i + 1 )
|
||||
return $ r : rs
|
||||
where
|
||||
displayTestMenu
|
||||
displayTestMenu
|
||||
= mapM_ displayTestMenu' testMenu
|
||||
displayTestMenu' ( i, t )
|
||||
= putStrLn $ ( if i == show nextID
|
||||
then "> "
|
||||
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
|
||||
let t = fromJust $ lookup i testMenu
|
||||
printSummary t
|
||||
waitForReturn
|
||||
testAction t
|
||||
@ -153,8 +153,8 @@ data Test = Test
|
||||
, confirmResults :: IO Bool
|
||||
}
|
||||
|
||||
allTests
|
||||
= [ reserveOutputTest
|
||||
allTests
|
||||
= [ reserveOutputTest
|
||||
, displayBoundsTest0
|
||||
, displayBoundsTest1
|
||||
, displayBoundsTest2
|
||||
@ -185,7 +185,7 @@ allTests
|
||||
, layer1
|
||||
]
|
||||
|
||||
reserveOutputTest = Test
|
||||
reserveOutputTest = Test
|
||||
{ testName = "Initialize and reserve terminal output then restore previous state."
|
||||
, testID = "reserveOutputTest"
|
||||
, testAction = do
|
||||
@ -203,7 +203,7 @@ reserveOutputTest = Test
|
||||
, printSummary = do
|
||||
putStr $ [s|
|
||||
Once return is pressed:
|
||||
0. The screen will be cleared.
|
||||
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.
|
||||
|
||||
@ -391,7 +391,7 @@ utf8Txt0 = [ [ 0xe2 , 0x86 , 0x91 ]
|
||||
|
||||
iso10646Txt0 :: String
|
||||
iso10646Txt0 = map toEnum
|
||||
[ 8593
|
||||
[ 8593
|
||||
, 8593
|
||||
, 8595
|
||||
, 8595
|
||||
@ -554,11 +554,11 @@ After return is pressed for the second time:
|
||||
allColors = zip [ black, red, green, yellow, blue, magenta, cyan, white ]
|
||||
[ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ]
|
||||
|
||||
allBrightColors
|
||||
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
|
||||
@ -604,7 +604,7 @@ Did the test output match the description?
|
||||
defaultSuccessConfirmResults
|
||||
}
|
||||
|
||||
attributesTest1 = Test
|
||||
attributesTest1 = Test
|
||||
{ testName = "Character attributes: background colors."
|
||||
, testID = "attributesTest1"
|
||||
, testAction = do
|
||||
@ -659,7 +659,7 @@ Did the test output match the description?
|
||||
defaultSuccessConfirmResults
|
||||
}
|
||||
|
||||
attributesTest2 = Test
|
||||
attributesTest2 = Test
|
||||
{ testName = "Character attributes: Vivid foreground colors."
|
||||
, testID = "attributesTest2"
|
||||
, testAction = do
|
||||
@ -686,23 +686,23 @@ Once return is pressed:
|
||||
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.
|
||||
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.
|
||||
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.
|
||||
rendered in the magenta color.
|
||||
|
||||
I'm not actually sure exactly what "vivid" means in this context. For xterm the
|
||||
vivid colors are brighter.
|
||||
vivid colors are brighter.
|
||||
|
||||
Verify:
|
||||
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.
|
||||
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.
|
||||
@ -718,7 +718,7 @@ Did the test output match the description?
|
||||
defaultSuccessConfirmResults
|
||||
}
|
||||
|
||||
attributesTest3 = Test
|
||||
attributesTest3 = Test
|
||||
{ testName = "Character attributes: Vivid background colors."
|
||||
, testID = "attributesTest3"
|
||||
, testAction = do
|
||||
@ -746,23 +746,23 @@ Once return is pressed:
|
||||
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.
|
||||
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.
|
||||
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.
|
||||
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:
|
||||
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.
|
||||
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.
|
||||
@ -785,7 +785,7 @@ Did the test output match the description?
|
||||
defaultSuccessConfirmResults
|
||||
}
|
||||
|
||||
attrCombos =
|
||||
attrCombos =
|
||||
[ ( "default", id )
|
||||
, ( "bold", flip withStyle bold )
|
||||
, ( "blink", flip withStyle blink )
|
||||
@ -796,7 +796,7 @@ attrCombos =
|
||||
, ( "bold + blink + underline", flip withStyle (bold + blink + underline) )
|
||||
]
|
||||
|
||||
attributesTest4 = Test
|
||||
attributesTest4 = Test
|
||||
{ testName = "Character attributes: Bold; Blink; Underline."
|
||||
, testID = "attributesTest4"
|
||||
, testAction = do
|
||||
@ -819,10 +819,10 @@ attributesTest4 = Test
|
||||
Once return is pressed:
|
||||
0. The screen will be cleared.
|
||||
1. The cursor will be hidden.
|
||||
2. 8 rows of text in two columns.
|
||||
2. 8 rows of text in two columns.
|
||||
The rows will contain the following text:
|
||||
default
|
||||
bold
|
||||
bold
|
||||
blink
|
||||
underline
|
||||
bold + blink
|
||||
@ -831,8 +831,8 @@ Once return is pressed:
|
||||
bold + blink + underline
|
||||
The first column will be rendered with the described attributes. The second
|
||||
column will be rendered with the default attributes.
|
||||
|
||||
Verify:
|
||||
|
||||
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.
|
||||
@ -848,7 +848,7 @@ Did the test output match the description?
|
||||
defaultSuccessConfirmResults
|
||||
}
|
||||
|
||||
attributesTest5 = Test
|
||||
attributesTest5 = Test
|
||||
{ testName = "Character attributes: 240 color palette"
|
||||
, testID = "attributesTest5"
|
||||
, testAction = do
|
||||
@ -873,7 +873,7 @@ Once return is pressed:
|
||||
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:
|
||||
Verify:
|
||||
|
||||
After return is pressed for the second time:
|
||||
0. The screen containing the test summary should be restored.
|
||||
@ -971,7 +971,7 @@ outputPicAndWait pic = do
|
||||
releaseDisplay t
|
||||
releaseTerminal t
|
||||
return ()
|
||||
|
||||
|
||||
vertCropTest0 :: Test
|
||||
vertCropTest0 = Test
|
||||
{ testName = "Verify bottom cropping works as expected with single column chars"
|
||||
@ -1046,7 +1046,7 @@ horizCropTest0 = Test
|
||||
, testID = "cropTest0"
|
||||
, testAction = do
|
||||
let baseImage = vertCat $ map (string defAttr) lorumIpsum
|
||||
croppedImage = cropRight (imageWidth baseImage `div` 2) baseImage
|
||||
croppedImage = cropRight (imageWidth baseImage `div` 2) baseImage
|
||||
image = baseImage <-> backgroundFill 10 2 <-> croppedImage
|
||||
outputImageAndWait image
|
||||
, printSummary = putStr $ [s|
|
||||
@ -1063,7 +1063,7 @@ horizCropTest1 = Test
|
||||
, testID = "cropTest0"
|
||||
, testAction = do
|
||||
let baseImage = vertCat $ map (string defAttr) lorumIpsumChinese
|
||||
croppedImage = cropRight (imageWidth baseImage `div` 2) baseImage
|
||||
croppedImage = cropRight (imageWidth baseImage `div` 2) baseImage
|
||||
image = baseImage <-> backgroundFill 10 2 <-> croppedImage
|
||||
outputImageAndWait image
|
||||
, printSummary = putStr $ [s|
|
||||
@ -1080,7 +1080,7 @@ horizCropTest2 = Test
|
||||
, testID = "cropTest0"
|
||||
, testAction = do
|
||||
let baseImage = vertCat $ map (string defAttr) lorumIpsum
|
||||
croppedImage = cropLeft (imageWidth baseImage `div` 2) baseImage
|
||||
croppedImage = cropLeft (imageWidth baseImage `div` 2) baseImage
|
||||
image = baseImage <-> backgroundFill 10 2 <-> croppedImage
|
||||
outputImageAndWait image
|
||||
, printSummary = putStr $ [s|
|
||||
@ -1097,7 +1097,7 @@ horizCropTest3 = Test
|
||||
, testID = "cropTest0"
|
||||
, testAction = do
|
||||
let baseImage = vertCat $ map (string defAttr) lorumIpsumChinese
|
||||
croppedImage = cropLeft (imageWidth baseImage `div` 2) baseImage
|
||||
croppedImage = cropLeft (imageWidth baseImage `div` 2) baseImage
|
||||
image = baseImage <-> backgroundFill 10 2 <-> croppedImage
|
||||
outputImageAndWait image
|
||||
, printSummary = putStr $ [s|
|
||||
|
||||
Loading…
Reference in New Issue
Block a user