a4ef14d · vty · git.iko.soy

git.iko.soy/vty

on master help sign in

refactor vty to use standard naming convention.

a4ef14dCorey O'Connor13 years ago

CHANGELOG+5−3

compare with master

unifiedsplit

@@ -1,4 +1,6 @@

15.0.0

2+ * The naming convention now matches:

3+ * http://www.haskell.org/haskellwiki/Programming_guidelines#Naming_Conventions

2 * all projects using vty for input must be compiled with -threaded. This could be resolved but

4 * all projects using vty for input must be compiled with -threaded. This could be resolved but

3 would like to avoid the complexity for now.

5 would like to avoid the complexity for now.

4 * mkVtyEscDelay has been removed. Use "mkVty def". Which initialized vty with the default

6 * mkVtyEscDelay has been removed. Use "mkVty def". Which initialized vty with the default

@@ -27,14 +29,14 @@

27 added to to pad images when images of different sizes are joined.

29 added to to pad images when images of different sizes are joined.

28 * If the background is clear there is no background layer.

30 * If the background is clear there is no background layer.

29 * If there is a background character then the bottom layer is the background layer.

31 * If there is a background character then the bottom layer is the background layer.

30− * empty_picture is a Picture with no layers and no cursor

32+ * emptyPicture is a Picture with no layers and no cursor

31− * add_to_top and add_to_bottom add a layer to the top and bottom of the given Picture.

33+ * addToTop and addToBottom add a layer to the top and bottom of the given Picture.

32 * compatibility improvements:

34 * compatibility improvements:

33 * terminfo based terminals with no cursor support are silently accepted. The cursor

35 * terminfo based terminals with no cursor support are silently accepted. The cursor

34 visibility changes in the Picture will have no effect.

36 visibility changes in the Picture will have no effect.

35 * alternate (setf/setb) color maps supported. Though colors beyond the first 8 are just a

37 * alternate (setf/setb) color maps supported. Though colors beyond the first 8 are just a

36 guess.

38 guess.

37− * added "rgb_color" for easy support of RGB specified colors.

39+ * added "rgbColor" for easy support of RGB specified colors.

38 * examples moved to vty-examples package. See test directory for cabal file.

40 * examples moved to vty-examples package. See test directory for cabal file.

39 * vty-interactive-terminal-test

41 * vty-interactive-terminal-test

40 * interactive test. Useful for building a bug report for vty's author.

42 * interactive test. Useful for building a bug report for vty's author.

scripts/256colres.pl+3−3

@@ -59,9 +59,9 @@ import Text.Printf

59--

60-- generated from 256colres.pl which is forked from xterm 256colres.pl

61-- todo: all values get clamped high.

62−rgb_color :: Integral i => i -> i -> i -> Color

62+rgbColor :: Integral i => i -> i -> i -> Color

63−rgb_color r g b

63+rgbColor r g b

64− | r < 0 && g < 0 && b < 0 = error "rgb_color with negative color component intensity"

64+ | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"

65EOF

67my $grey_line=" | r == %d && g == %d && b == %d = Color240 %d\n";

src/Codec/Binary/UTF8/Debug.hs+4−4

@@ -10,9 +10,9 @@ import Numeric

11-- | Converts an array of ISO-10646 characters (Char type) to an array of Word8 bytes that is the

12-- corresponding UTF8 byte sequence

13−utf8_from_iso :: [Int] -> [Word8]

13+utf8FromIso :: [Int] -> [Word8]

14−utf8_from_iso = encode . map toEnum

14+utf8FromIso = encode . map toEnum

16−pp_utf8 :: [Int] -> IO ()

16+ppUtf8 :: [Int] -> IO ()

17−pp_utf8 = print . map (\f -> f "") . map showHex . utf8_from_iso

17+ppUtf8 = print . map (\f -> f "") . map showHex . utf8FromIso

src/Data/Terminfo/Eval.hs+46−48

@@ -3,9 +3,8 @@

3{-# OPTIONS_GHC -funbox-strict-fields #-}

4{- Evaluates the paramaterized terminfo string capability with the given parameters.

5 -

6− - todo: This can be greatly simplified.

7 -}

6 -}

8−module Data.Terminfo.Eval (write_cap_expr)

7+module Data.Terminfo.Eval (writeCapExpr)

9 where

8 where

11import Blaze.ByteString.Builder.Word

10import Blaze.ByteString.Builder.Word

@@ -24,9 +23,9 @@ import qualified Data.Vector.Unboxed as Vector

25-- | capability evaluator state

24-- | capability evaluator state

26data EvalState = EvalState

25data EvalState = EvalState

27− { eval_stack :: ![CapParam]

26+ { evalStack :: ![CapParam]

28− , eval_expression :: !CapExpression

27+ , evalExpression :: !CapExpression

29− , eval_params :: ![CapParam]

28+ , evalParams :: ![CapParam]

30 }

29 }

32type Eval a = StateT EvalState (Writer Write) a

31type Eval a = StateT EvalState (Writer Write) a

@@ -34,98 +33,97 @@ type Eval a = StateT EvalState (Writer Write) a

34pop :: Eval CapParam

33pop :: Eval CapParam

35pop = do

34pop = do

36 s <- get

35 s <- get

37− let v : stack' = eval_stack s

36+ let v : stack' = evalStack s

38− s' = s { eval_stack = stack' }

37+ s' = s { evalStack = stack' }

39 put s'

38 put s'

40 return v

39 return v

42−read_param :: Word -> Eval CapParam

41+readParam :: Word -> Eval CapParam

43−read_param pn = do

42+readParam pn = do

44− !params <- get >>= return . eval_params

43+ !params <- get >>= return . evalParams

45 return $! genericIndex params pn

44 return $! genericIndex params pn

47push :: CapParam -> Eval ()

46push :: CapParam -> Eval ()

48push !v = do

47push !v = do

49 s <- get

48 s <- get

50− let s' = s { eval_stack = v : eval_stack s }

49+ let s' = s { evalStack = v : evalStack s }

51 put s'

50 put s'

53−apply_param_ops :: CapExpression -> [CapParam] -> [CapParam]

52+applyParamOps :: CapExpression -> [CapParam] -> [CapParam]

54−apply_param_ops cap params = foldl apply_param_op params (param_ops cap)

53+applyParamOps cap params = foldl applyParamOp params (paramOps cap)

56−apply_param_op :: [CapParam] -> ParamOp -> [CapParam]

55+applyParamOp :: [CapParam] -> ParamOp -> [CapParam]

57−apply_param_op params IncFirstTwo = map (+ 1) params

56+applyParamOp params IncFirstTwo = map (+ 1) params

59−write_cap_expr :: CapExpression -> [CapParam] -> Write

58+writeCapExpr :: CapExpression -> [CapParam] -> Write

60−write_cap_expr cap params =

59+writeCapExpr cap params =

61− let params' = apply_param_ops cap params

60+ let params' = applyParamOps cap params

62 s_0 = EvalState [] cap params'

61 s_0 = EvalState [] cap params'

63− in snd $ runWriter (runStateT (write_cap_ops (cap_ops cap)) s_0)

62+ in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s_0)

65−write_cap_ops :: CapOps -> Eval ()

64+writeCapOps :: CapOps -> Eval ()

66−write_cap_ops ops = mapM_ write_cap_op ops

65+writeCapOps ops = mapM_ writeCapOp ops

68−write_cap_op :: CapOp -> Eval ()

67+writeCapOp :: CapOp -> Eval ()

69−write_cap_op (Bytes !offset !count) = do

68+writeCapOp (Bytes !offset !count) = do

70− !cap <- get >>= return . eval_expression

69+ !cap <- get >>= return . evalExpression

71− let bytes = Vector.take count $ Vector.drop offset (cap_bytes cap)

70+ let bytes = Vector.take count $ Vector.drop offset (capBytes cap)

72 Vector.forM_ bytes $ tell.writeWord8

71 Vector.forM_ bytes $ tell.writeWord8

73−write_cap_op DecOut = do

72+writeCapOp DecOut = do

74 p <- pop

73 p <- pop

75− let out_str = show p

76− forM_ out_str $ tell.writeWord8.toEnum.fromEnum

74+ forM_ (show p) $ tell.writeWord8.toEnum.fromEnum

77−write_cap_op CharOut = do

75+writeCapOp CharOut = do

78 pop >>= tell.writeWord8.toEnum.fromEnum

76 pop >>= tell.writeWord8.toEnum.fromEnum

79−write_cap_op (PushParam pn) = do

77+writeCapOp (PushParam pn) = do

80− read_param pn >>= push

78+ readParam pn >>= push

81−write_cap_op (PushValue v) = do

79+writeCapOp (PushValue v) = do

82 push v

80 push v

83−write_cap_op (Conditional expr parts) = do

81+writeCapOp (Conditional expr parts) = do

84− write_cap_ops expr

82+ writeCapOps expr

85− write_contitional_parts parts

83+ writeContitionalParts parts

86 where

84 where

87− write_contitional_parts [] = return ()

85+ writeContitionalParts [] = return ()

88− write_contitional_parts ((true_ops, false_ops) : false_parts) = do

86+ writeContitionalParts ((trueOps, false_ops) : falseParts) = do

89 -- (man 5 terminfo)

87 -- (man 5 terminfo)

90 -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the

88 -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the

91 -- stack, testing if it is nonzero (true). If it is zero (false), control

89 -- stack, testing if it is nonzero (true). If it is zero (false), control

92 -- passes to the %e (else) part.

90 -- passes to the %e (else) part.

93 v <- pop

91 v <- pop

94 if v /= 0

92 if v /= 0

95− then write_cap_ops true_ops

93+ then writeCapOps trueOps

96 else do

94 else do

97− write_cap_ops false_ops

95+ writeCapOps false_ops

98− write_contitional_parts false_parts

96+ writeContitionalParts falseParts

100−write_cap_op BitwiseOr = do

98+writeCapOp BitwiseOr = do

101 v_0 <- pop

99 v_0 <- pop

102 v_1 <- pop

100 v_1 <- pop

103 push $ v_0 .|. v_1

101 push $ v_0 .|. v_1

104−write_cap_op BitwiseAnd = do

102+writeCapOp BitwiseAnd = do

105 v_0 <- pop

103 v_0 <- pop

106 v_1 <- pop

104 v_1 <- pop

107 push $ v_0 .&. v_1

105 push $ v_0 .&. v_1

108−write_cap_op BitwiseXOr = do

106+writeCapOp BitwiseXOr = do

109 v_1 <- pop

107 v_1 <- pop

110 v_0 <- pop

108 v_0 <- pop

111 push $ v_0 `xor` v_1

109 push $ v_0 `xor` v_1

112−write_cap_op ArithPlus = do

110+writeCapOp ArithPlus = do

113 v_1 <- pop

111 v_1 <- pop

114 v_0 <- pop

112 v_0 <- pop

115 push $ v_0 + v_1

113 push $ v_0 + v_1

116−write_cap_op ArithMinus = do

114+writeCapOp ArithMinus = do

117 v_1 <- pop

115 v_1 <- pop

118 v_0 <- pop

116 v_0 <- pop

119 push $ v_0 - v_1

117 push $ v_0 - v_1

120−write_cap_op CompareEq = do

118+writeCapOp CompareEq = do

121 v_1 <- pop

119 v_1 <- pop

122 v_0 <- pop

120 v_0 <- pop

123 push $ if v_0 == v_1 then 1 else 0

121 push $ if v_0 == v_1 then 1 else 0

124−write_cap_op CompareLt = do

122+writeCapOp CompareLt = do

125 v_1 <- pop

123 v_1 <- pop

126 v_0 <- pop

124 v_0 <- pop

127 push $ if v_0 < v_1 then 1 else 0

125 push $ if v_0 < v_1 then 1 else 0

128−write_cap_op CompareGt = do

126+writeCapOp CompareGt = do

129 v_1 <- pop

127 v_1 <- pop

130 v_0 <- pop

128 v_0 <- pop

131 push $ if v_0 > v_1 then 1 else 0

129 push $ if v_0 > v_1 then 1 else 0

src/Data/Terminfo/Parse.hs+172−172

@@ -19,25 +19,25 @@ import Numeric (showHex)

19import Text.ParserCombinators.Parsec

21data CapExpression = CapExpression

22− { cap_ops :: !CapOps

22+ { capOps :: !CapOps

23− , cap_bytes :: !(Vector.Vector Word8)

23+ , capBytes :: !(Vector.Vector Word8)

24− , source_string :: !String

24+ , sourceString :: !String

25− , param_count :: !Int

25+ , paramCount :: !Int

26− , param_ops :: !ParamOps

26+ , paramOps :: !ParamOps

27 } deriving (Eq)

29instance Show CapExpression where

30 show c

31− = "CapExpression { " ++ show (cap_ops c) ++ " }"

31+ = "CapExpression { " ++ show (capOps c) ++ " }"

32− ++ " <- [" ++ hex_dump ( map ( toEnum . fromEnum ) $! source_string c ) ++ "]"

32+ ++ " <- [" ++ hex_dump ( map ( toEnum . fromEnum ) $! sourceString c ) ++ "]"

33− ++ " <= " ++ show (source_string c)

33+ ++ " <= " ++ show (sourceString c)

34 where

35 hex_dump :: [Word8] -> String

36 hex_dump = foldr (\b s -> showHex b s) ""

38instance NFData CapExpression where

39− rnf (CapExpression ops !_bytes !str !c !p_ops)

39+ rnf (CapExpression ops !_bytes !str !c !pOps)

40− = rnf ops `seq` rnf str `seq` rnf c `seq` rnf p_ops

40+ = rnf ops `seq` rnf str `seq` rnf c `seq` rnf pOps

42type CapParam = Word

@@ -60,10 +60,10 @@ data CapOp =

60 deriving (Show, Eq)

62instance NFData CapOp where

63− rnf (Bytes offset byte_count ) = rnf offset `seq` rnf byte_count

63+ rnf (Bytes offset byteCount ) = rnf offset `seq` rnf byteCount

64 rnf (PushParam pn) = rnf pn

65 rnf (PushValue v) = rnf v

66− rnf (Conditional c_expr c_parts) = rnf c_expr `seq` rnf c_parts

66+ rnf (Conditional cExpr cParts) = rnf cExpr `seq` rnf cParts

67 rnf BitwiseOr = ()

68 rnf BitwiseXOr = ()

69 rnf BitwiseAnd = ()

@@ -83,256 +83,256 @@ data ParamOp =

83instance NFData ParamOp where

84 rnf IncFirstTwo = ()

86−parse_cap_expression :: String -> Either ParseError CapExpression

86+parseCapExpression :: String -> Either ParseError CapExpression

87−parse_cap_expression cap_string =

87+parseCapExpression capString =

88− let v = runParser cap_expression_parser

88+ let v = runParser capExpressionParser

89− initial_build_state

89+ initialBuildState

90− "terminfo cap"

90+ "terminfo cap"

91− cap_string

91+ capString

92 in case v of

93 Left e -> Left e

94− Right build_results -> Right $ construct_cap_expression cap_string build_results

94+ Right buildResults -> Right $ constructCapExpression capString buildResults

96−construct_cap_expression :: [Char] -> BuildResults -> CapExpression

96+constructCapExpression :: [Char] -> BuildResults -> CapExpression

97−construct_cap_expression cap_string build_results =

97+constructCapExpression capString buildResults =

98 let expr = CapExpression

99− { cap_ops = out_cap_ops build_results

99+ { capOps = outCapOps buildResults

100 -- The cap bytes are the lower 8 bits of the input string's characters.

101 -- \todo Verify the input string actually contains an 8bit byte per character.

102− , cap_bytes = Vector.fromList $ map (toEnum.fromEnum) cap_string

102+ , capBytes = Vector.fromList $ map (toEnum.fromEnum) capString

103− , source_string = cap_string

103+ , sourceString = capString

104− , param_count = out_param_count build_results

104+ , paramCount = outParamCount buildResults

105− , param_ops = out_param_ops build_results

105+ , paramOps = outParamOps buildResults

106 }

107 in rnf expr `seq` expr

108

109type CapParser a = GenParser Char BuildState a

110

111−cap_expression_parser :: CapParser BuildResults

111+capExpressionParser :: CapParser BuildResults

112−cap_expression_parser = do

112+capExpressionParser = do

113− rs <- many $ param_escape_parser <|> bytes_op_parser

113+ rs <- many $ paramEscapeParser <|> bytesOpParser

114 return $ mconcat rs

115

116−param_escape_parser :: CapParser BuildResults

116+paramEscapeParser :: CapParser BuildResults

117−param_escape_parser = do

117+paramEscapeParser = do

118 _ <- char '%'

119− inc_offset 1

119+ incOffset 1

120− literal_percent_parser <|> param_op_parser

120+ literalPercentParser <|> paramOpParser

121

122−literal_percent_parser :: CapParser BuildResults

122+literalPercentParser :: CapParser BuildResults

123−literal_percent_parser = do

123+literalPercentParser = do

124 _ <- char '%'

125− start_offset <- getState >>= return . next_offset

125+ startOffset <- getState >>= return . nextOffset

126− inc_offset 1

126+ incOffset 1

127− return $ BuildResults 0 [Bytes start_offset 1] []

127+ return $ BuildResults 0 [Bytes startOffset 1] []

128−

128+

129−param_op_parser :: CapParser BuildResults

129+paramOpParser :: CapParser BuildResults

130−param_op_parser

130+paramOpParser

131− = increment_op_parser

131+ = incrementOpParser

132− <|> push_op_parser

132+ <|> pushOpParser

133− <|> dec_out_parser

133+ <|> decOutParser

134− <|> char_out_parser

134+ <|> charOutParser

135− <|> conditional_op_parser

135+ <|> conditionalOpParser

136− <|> bitwise_op_parser

136+ <|> bitwiseOpParser

137− <|> arith_op_parser

137+ <|> arithOpParser

138− <|> literal_int_op_parser

138+ <|> literalIntOpParser

139− <|> compare_op_parser

139+ <|> compareOpParser

140− <|> char_const_parser

140+ <|> charConstParser

141−

141+

142−increment_op_parser :: CapParser BuildResults

142+incrementOpParser :: CapParser BuildResults

143−increment_op_parser = do

143+incrementOpParser = do

144 _ <- char 'i'

145− inc_offset 1

145+ incOffset 1

146 return $ BuildResults 0 [] [ IncFirstTwo ]

147

148−push_op_parser :: CapParser BuildResults

148+pushOpParser :: CapParser BuildResults

149−push_op_parser = do

149+pushOpParser = do

150 _ <- char 'p'

151− param_n <- digit >>= return . (\d -> read [d])

151+ paramN <- digit >>= return . (\d -> read [d])

152− inc_offset 2

152+ incOffset 2

153− return $ BuildResults (fromEnum param_n) [PushParam $ param_n - 1] []

153+ return $ BuildResults (fromEnum paramN) [PushParam $ paramN - 1] []

154

155−dec_out_parser :: CapParser BuildResults

155+decOutParser :: CapParser BuildResults

156−dec_out_parser = do

156+decOutParser = do

157 _ <- char 'd'

158− inc_offset 1

158+ incOffset 1

159 return $ BuildResults 0 [ DecOut ] []

160

161−char_out_parser :: CapParser BuildResults

161+charOutParser :: CapParser BuildResults

162−char_out_parser = do

162+charOutParser = do

163 _ <- char 'c'

164− inc_offset 1

164+ incOffset 1

165 return $ BuildResults 0 [ CharOut ] []

166

167−conditional_op_parser :: CapParser BuildResults

167+conditionalOpParser :: CapParser BuildResults

168−conditional_op_parser = do

168+conditionalOpParser = do

169 _ <- char '?'

170− inc_offset 1

170+ incOffset 1

171− cond_part <- many_expr conditional_true_parser

171+ cond_part <- manyExpr conditionalTrueParser

172− parts <- many_p

172+ parts <- manyP

173− ( do

173+ ( do

174− true_part <- many_expr $ choice [ try $ lookAhead conditional_end_parser

174+ truePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser

175− , conditional_false_parser

175+ , conditionalFalseParser

176− ]

176+ ]

177− false_part <- many_expr $ choice [ try $ lookAhead conditional_end_parser

177+ falsePart <- manyExpr $ choice [ try $ lookAhead conditionalEndParser

178− , conditional_true_parser

178+ , conditionalTrueParser

179− ]

179+ ]

180− return ( true_part, false_part )

180+ return ( truePart, falsePart )

181− )

181+ )

182− conditional_end_parser

182+ conditionalEndParser

183−

183+

184− let true_parts = map fst parts

184+ let trueParts = map fst parts

185− false_parts = map snd parts

185+ falseParts = map snd parts

186− BuildResults n cond cond_param_ops = cond_part

186+ BuildResults n cond condParamOps = cond_part

187−

187+

188− let n' = maximum $ n : map out_param_count true_parts

188+ let n' = maximum $ n : map outParamCount trueParts

189− n'' = maximum $ n' : map out_param_count false_parts

189+ n'' = maximum $ n' : map outParamCount falseParts

190−

190+

191− let true_ops = map out_cap_ops true_parts

191+ let trueOps = map outCapOps trueParts

192− false_ops = map out_cap_ops false_parts

192+ falseOps = map outCapOps falseParts

193− cond_parts = zip true_ops false_ops

193+ condParts = zip trueOps falseOps

194−

194+

195− let true_param_ops = mconcat $ map out_param_ops true_parts

195+ let trueParamOps = mconcat $ map outParamOps trueParts

196− false_param_ops = mconcat $ map out_param_ops false_parts

196+ falseParamOps = mconcat $ map outParamOps falseParts

197− p_ops = mconcat [cond_param_ops, true_param_ops, false_param_ops]

197+ pOps = mconcat [condParamOps, trueParamOps, falseParamOps]

198−

198+

199− return $ BuildResults n'' [ Conditional cond cond_parts ] p_ops

199+ return $ BuildResults n'' [ Conditional cond condParts ] pOps

200

201 where

202− many_p !p !end = choice

202+ manyP !p !end = choice

203 [ try end >> return []

204 , do !v <- p

205− !vs <- many_p p end

205+ !vs <- manyP p end

206 return $! v : vs

207 ]

208− many_expr end = liftM mconcat $ many_p ( param_escape_parser <|> bytes_op_parser ) end

208+ manyExpr end = liftM mconcat $ manyP ( paramEscapeParser <|> bytesOpParser ) end

209

210−conditional_true_parser :: CapParser ()

210+conditionalTrueParser :: CapParser ()

211−conditional_true_parser = do

211+conditionalTrueParser = do

212 _ <- string "%t"

213− inc_offset 2

213+ incOffset 2

214

215−conditional_false_parser :: CapParser ()

215+conditionalFalseParser :: CapParser ()

216−conditional_false_parser = do

216+conditionalFalseParser = do

217 _ <- string "%e"

218− inc_offset 2

218+ incOffset 2

219

220−conditional_end_parser :: CapParser ()

220+conditionalEndParser :: CapParser ()

221−conditional_end_parser = do

221+conditionalEndParser = do

222 _ <- string "%;"

223− inc_offset 2

223+ incOffset 2

224

225−bitwise_op_parser :: CapParser BuildResults

225+bitwiseOpParser :: CapParser BuildResults

226−bitwise_op_parser

226+bitwiseOpParser

227− = bitwise_or_parser

227+ = bitwiseOrParser

228− <|> bitwise_and_parser

228+ <|> bitwiseAndParser

229− <|> bitwise_xor_parser

229+ <|> bitwiseXorParser

230

231−bitwise_or_parser :: CapParser BuildResults

231+bitwiseOrParser :: CapParser BuildResults

232−bitwise_or_parser = do

232+bitwiseOrParser = do

233 _ <- char '|'

234− inc_offset 1

234+ incOffset 1

235 return $ BuildResults 0 [ BitwiseOr ] [ ]

236

237−bitwise_and_parser :: CapParser BuildResults

237+bitwiseAndParser :: CapParser BuildResults

238−bitwise_and_parser = do

238+bitwiseAndParser = do

239 _ <- char '&'

240− inc_offset 1

240+ incOffset 1

241 return $ BuildResults 0 [ BitwiseAnd ] [ ]

242

243−bitwise_xor_parser :: CapParser BuildResults

243+bitwiseXorParser :: CapParser BuildResults

244−bitwise_xor_parser = do

244+bitwiseXorParser = do

245 _ <- char '^'

246− inc_offset 1

246+ incOffset 1

247 return $ BuildResults 0 [ BitwiseXOr ] [ ]

248

249−arith_op_parser :: CapParser BuildResults

249+arithOpParser :: CapParser BuildResults

250−arith_op_parser

250+arithOpParser

251− = plus_op

251+ = plusOp

252− <|> minus_op

252+ <|> minusOp

253 where

254− plus_op = do

254+ plusOp = do

255 _ <- char '+'

256− inc_offset 1

256+ incOffset 1

257 return $ BuildResults 0 [ ArithPlus ] [ ]

258− minus_op = do

258+ minusOp = do

259 _ <- char '-'

260− inc_offset 1

260+ incOffset 1

261 return $ BuildResults 0 [ ArithMinus ] [ ]

262

263−literal_int_op_parser :: CapParser BuildResults

263+literalIntOpParser :: CapParser BuildResults

264−literal_int_op_parser = do

264+literalIntOpParser = do

265 _ <- char '{'

266− inc_offset 1

266+ incOffset 1

267− n_str <- many1 digit

267+ nStr <- many1 digit

268− inc_offset $ toEnum $ length n_str

268+ incOffset $ toEnum $ length nStr

269− let n :: Word = read n_str

269+ let n :: Word = read nStr

270 _ <- char '}'

271− inc_offset 1

271+ incOffset 1

272 return $ BuildResults 0 [ PushValue n ] [ ]

273

274−compare_op_parser :: CapParser BuildResults

274+compareOpParser :: CapParser BuildResults

275−compare_op_parser

275+compareOpParser

276− = compare_eq_op

276+ = compareEqOp

277− <|> compare_lt_op

277+ <|> compareLtOp

278− <|> compare_gt_op

278+ <|> compareGtOp

279 where

280− compare_eq_op = do

280+ compareEqOp = do

281 _ <- char '='

282− inc_offset 1

282+ incOffset 1

283 return $ BuildResults 0 [ CompareEq ] [ ]

284− compare_lt_op = do

284+ compareLtOp = do

285 _ <- char '<'

286− inc_offset 1

286+ incOffset 1

287 return $ BuildResults 0 [ CompareLt ] [ ]

288− compare_gt_op = do

288+ compareGtOp = do

289 _ <- char '>'

290− inc_offset 1

290+ incOffset 1

291 return $ BuildResults 0 [ CompareGt ] [ ]

292

293−bytes_op_parser :: CapParser BuildResults

293+bytesOpParser :: CapParser BuildResults

294−bytes_op_parser = do

294+bytesOpParser = do

295 bytes <- many1 $ satisfy (/= '%')

296− start_offset <- getState >>= return . next_offset

296+ startOffset <- getState >>= return . nextOffset

297 let !c = length bytes

298 !s <- getState

299− let s' = s { next_offset = start_offset + c }

299+ let s' = s { nextOffset = startOffset + c }

300 setState s'

301− return $ BuildResults 0 [Bytes start_offset c] []

301+ return $ BuildResults 0 [Bytes startOffset c] []

302

303−char_const_parser :: CapParser BuildResults

303+charConstParser :: CapParser BuildResults

304−char_const_parser = do

304+charConstParser = do

305 _ <- char '\''

306− char_value <- liftM (toEnum . fromEnum) anyChar

306+ charValue <- liftM (toEnum . fromEnum) anyChar

307 _ <- char '\''

308− inc_offset 3

308+ incOffset 3

309− return $ BuildResults 0 [ PushValue char_value ] [ ]

309+ return $ BuildResults 0 [ PushValue charValue ] [ ]

310

311data BuildState = BuildState

312− { next_offset :: Int

312+ { nextOffset :: Int

313 }

314

315−inc_offset :: Int -> CapParser ()

315+incOffset :: Int -> CapParser ()

316−inc_offset n = do

316+incOffset n = do

317 s <- getState

318− let s' = s { next_offset = next_offset s + n }

318+ let s' = s { nextOffset = nextOffset s + n }

319 setState s'

320

321−initial_build_state :: BuildState

321+initialBuildState :: BuildState

322−initial_build_state = BuildState 0

322+initialBuildState = BuildState 0

323

324data BuildResults = BuildResults

325− { out_param_count :: !Int

325+ { outParamCount :: !Int

326− , out_cap_ops :: !CapOps

326+ , outCapOps :: !CapOps

327− , out_param_ops :: !ParamOps

327+ , outParamOps :: !ParamOps

328 }

329

330instance Monoid BuildResults where

331 mempty = BuildResults 0 [] []

332 v0 `mappend` v1

333 = BuildResults

334− { out_param_count = (out_param_count v0) `max` (out_param_count v1)

334+ { outParamCount = (outParamCount v0) `max` (outParamCount v1)

335− , out_cap_ops = (out_cap_ops v0) `mappend` (out_cap_ops v1)

335+ , outCapOps = (outCapOps v0) `mappend` (outCapOps v1)

336− , out_param_ops = (out_param_ops v0) `mappend` (out_param_ops v1)

336+ , outParamOps = (outParamOps v0) `mappend` (outParamOps v1)

337 }

338

src/Graphics/Text/Width.hs+6−6

@@ -3,8 +3,8 @@

3{-# LANGUAGE ForeignFunctionInterface #-}

4module Graphics.Text.Width ( wcwidth

5 , wcswidth

6− , safe_wcwidth

6+ , safeWcwidth

7− , safe_wcswidth

7+ , safeWcswidth

8 )

9 where

@@ -21,14 +21,14 @@ wcswidth = sum . map wcwidth

21-- implemented.

23-- | Returns the display width of a character. Assumes all characters with unknown widths are 0 width

24−safe_wcwidth :: Char -> Int

24+safeWcwidth :: Char -> Int

25−safe_wcwidth c = case wcwidth c of

25+safeWcwidth c = case wcwidth c of

26 i | i < 0 -> 0

27 | otherwise -> i

29-- | Returns the display width of a string. Assumes all characters with unknown widths are 0 width

30−safe_wcswidth :: String -> Int

30+safeWcswidth :: String -> Int

31−safe_wcswidth str = case wcswidth str of

31+safeWcswidth str = case wcswidth str of

32 i | i < 0 -> 0

33 | otherwise -> i

src/Graphics/Vty.hs+43−43

@@ -60,16 +60,16 @@ import Data.IORef

60--

61-- \todo Remove explicit `shutdown` requirement.

62data Vty = Vty

63− { -- | Outputs the given Picture. Equivalent to 'output_picture' applied to a display context

63+ { -- | Outputs the given Picture. Equivalent to 'outputPicture' applied to a display context

64 -- implicitly managed by Vty. The managed display context is reset on resize.

65 update :: Picture -> IO ()

66 -- | Get one Event object, blocking if necessary. This will refresh the terminal if the event

67 -- is a 'EvResize'.

68− , next_event :: IO Event

68+ , nextEvent :: IO Event

69 -- | The input interface. See 'Input'

70− , input_iface :: Input

70+ , inputIface :: Input

71 -- | The output interface. See 'Output'

72− , output_iface :: Output

72+ , outputIface :: Output

73 -- | Refresh the display. Normally the library takes care of refreshing. Nonetheless, some

74 -- other program might output to the terminal and mess up the display. In that case the

75 -- application might want to force a refresh.

@@ -83,24 +83,24 @@ data Vty = Vty

83-- created at a time.

84mkVty :: Config -> IO Vty

85mkVty config = do

86− input <- input_for_current_terminal config

86+ input <- inputForCurrentTerminal config

87− out <- output_for_current_terminal

87+ out <- outputForCurrentTerminal

88 intMkVty input out

90intMkVty :: Input -> Output -> IO Vty

91intMkVty input out = do

92− reserve_display out

92+ reserveDisplay out

93− let shutdown_io = do

93+ let shutdownIo = do

94− shutdown_input input

94+ shutdownInput input

95− release_display out

95+ releaseDisplay out

96− release_terminal out

96+ releaseTerminal out

97− last_pic_ref <- newIORef Nothing

97+ lastPicRef <- newIORef Nothing

98− last_update_ref <- newIORef Nothing

98+ lastUpdateRef <- newIORef Nothing

100− let inner_update in_pic = do

100+ let innerUpdate inPic = do

101− b@(w,h) <- display_bounds out

101+ b@(w,h) <- displayBounds out

102− let cursor = pic_cursor in_pic

102+ let cursor = picCursor inPic

103− in_pic' = case cursor of

103+ inPic' = case cursor of

104 Cursor x y ->

105 let

106 x' = case x of

@@ -111,43 +111,43 @@ intMkVty input out = do

111 _ | y < 0 -> 0

112 | y >= h -> h - 1

113 | otherwise -> y

114− in in_pic { pic_cursor = Cursor x' y' }

114+ in inPic { picCursor = Cursor x' y' }

115− _ -> in_pic

115+ _ -> inPic

116− mlast_update <- readIORef last_update_ref

116+ mlastUpdate <- readIORef lastUpdateRef

117− update_data <- case mlast_update of

117+ updateData <- case mlastUpdate of

118 Nothing -> do

119− dc <- display_context out b

119+ dc <- displayContext out b

120− output_picture dc in_pic'

120+ outputPicture dc inPic'

121 return (b, dc)

122− Just (last_bounds, last_context) -> do

122+ Just (last_bounds, lastContext) -> do

123 if b /= last_bounds

124 then do

125− dc <- display_context out b

125+ dc <- displayContext out b

126− output_picture dc in_pic'

126+ outputPicture dc inPic'

127 return (b, dc)

128 else do

129− output_picture last_context in_pic'

129+ outputPicture lastContext inPic'

130− return (b, last_context)

130+ return (b, lastContext)

131− writeIORef last_update_ref $ Just update_data

131+ writeIORef lastUpdateRef $ Just updateData

132− writeIORef last_pic_ref $ Just in_pic'

132+ writeIORef lastPicRef $ Just inPic'

133

134− let inner_refresh

134+ let innerRefresh

135− = writeIORef last_update_ref Nothing

135+ = writeIORef lastUpdateRef Nothing

136− >> readIORef last_pic_ref

136+ >> readIORef lastPicRef

137− >>= maybe ( return () ) ( \pic -> inner_update pic )

137+ >>= maybe ( return () ) ( \pic -> innerUpdate pic )

138

139− let gkey = do k <- readChan $ _event_channel input

139+ let gkey = do k <- readChan $ _eventChannel input

140 case k of

141− (EvResize _ _) -> inner_refresh

141+ (EvResize _ _) -> innerRefresh

142− >> display_bounds out

142+ >> displayBounds out

143 >>= return . (\(w,h)-> EvResize w h)

144 _ -> return k

145

146− return $ Vty { update = inner_update

146+ return $ Vty { update = innerUpdate

147− , next_event = gkey

147+ , nextEvent = gkey

148− , input_iface = input

148+ , inputIface = input

149− , output_iface = out

149+ , outputIface = out

150− , refresh = inner_refresh

150+ , refresh = innerRefresh

151− , shutdown = shutdown_io

151+ , shutdown = shutdownIo

152 }

153

src/Graphics/Vty/Attributes.hs+50−46

@@ -3,10 +3,10 @@

3{-# LANGUAGE RankNTypes #-}

4-- | Display attributes

5--

6−-- Typically the values 'def_attr' or 'current_attr' are modified to form attributes:

6+-- Typically the values 'defAttr' or 'currentAttr' are modified to form attributes:

7--

8-- @

9−-- def_attr `with_fore_color` red

9+-- defAttr `withForeColor` red

10-- @

11--

12-- Is the attribute that will set the foreground color to red and the background color to the

@@ -15,14 +15,14 @@

15-- This can then be used to build an image wiht a red foreground like so:

16--

17-- @

18−-- string (def_attr `with_fore_color` red) "this text will be red"

18+-- string (defAttr `withForeColor` red) "this text will be red"

19-- @

20--

21−-- The default attributes set by 'def_attr' have a presentation determined by the terminal. This is

21+-- The default attributes set by 'defAttr' have a presentation determined by the terminal. This is

22-- not something VTY can control. The user is free to define the color scheme of the terminal as

23-- they see fit. Up to the limits of the terminal anyways.

24--

25−-- The value 'current_attr' will keep the attributes of whatever was output previously.

25+-- The value 'currentAttr' will keep the attributes of whatever was output previously.

26--

27-- \todo This API is very verbose IMO. I'd like something more succinct.

28module Graphics.Vty.Attributes ( module Graphics.Vty.Attributes

@@ -32,6 +32,7 @@ module Graphics.Vty.Attributes ( module Graphics.Vty.Attributes

32 where

34import Data.Bits

35+import Data.Default

35import Data.Monoid

36import Data.Monoid

36import Data.Word

37import Data.Word

@@ -45,9 +46,9 @@ import Graphics.Vty.Attributes.Color240

45-- foreground. The 240 colors and 16 colors are points in different palettes. See Color for more

46-- foreground. The 240 colors and 16 colors are points in different palettes. See Color for more

46-- information.

47-- information.

47data Attr = Attr

48data Attr = Attr

48− { attr_style :: !(MaybeDefault Style)

49+ { attrStyle :: !(MaybeDefault Style)

49− , attr_fore_color :: !(MaybeDefault Color)

50+ , attrForeColor :: !(MaybeDefault Color)

50− , attr_back_color :: !(MaybeDefault Color)

51+ , attrBackColor :: !(MaybeDefault Color)

51 } deriving ( Eq, Show )

52 } deriving ( Eq, Show )

53-- This could be encoded into a single 32 bit word. The 32 bit word is first divided

54-- This could be encoded into a single 32 bit word. The 32 bit word is first divided

@@ -84,17 +85,17 @@ data Attr = Attr

84instance Monoid Attr where

85instance Monoid Attr where

85 mempty = Attr mempty mempty mempty

86 mempty = Attr mempty mempty mempty

86 mappend attr_0 attr_1 =

87 mappend attr_0 attr_1 =

87− Attr ( attr_style attr_0 `mappend` attr_style attr_1 )

88+ Attr ( attrStyle attr_0 `mappend` attrStyle attr_1 )

88− ( attr_fore_color attr_0 `mappend` attr_fore_color attr_1 )

89+ ( attrForeColor attr_0 `mappend` attrForeColor attr_1 )

89− ( attr_back_color attr_0 `mappend` attr_back_color attr_1 )

90+ ( attrBackColor attr_0 `mappend` attrBackColor attr_1 )

91-- | Specifies the display attributes such that the final style and color values do not depend on

92-- | Specifies the display attributes such that the final style and color values do not depend on

92-- the previously applied display attribute. The display attributes can still depend on the

93-- the previously applied display attribute. The display attributes can still depend on the

93-- terminal's default colors (unfortunately).

94-- terminal's default colors (unfortunately).

94data FixedAttr = FixedAttr

95data FixedAttr = FixedAttr

95− { fixed_style :: !Style

96+ { fixedStyle :: !Style

96− , fixed_fore_color :: !(Maybe Color)

97+ , fixedForeColor :: !(Maybe Color)

97− , fixed_back_color :: !(Maybe Color)

98+ , fixedBackColor :: !(Maybe Color)

98 } deriving ( Eq, Show )

99 } deriving ( Eq, Show )

100

100-- | The style and color attributes can either be the terminal defaults. Or be equivalent to the

101-- | The style and color attributes can either be the terminal defaults. Or be equivalent to the

@@ -131,16 +132,16 @@ cyan = ISOColor 6

131white = ISOColor 7

132white = ISOColor 7

132

133

133-- | Bright/Vivid variants of the standard 8-color ANSI

134-- | Bright/Vivid variants of the standard 8-color ANSI

134−bright_black, bright_red, bright_green, bright_yellow :: Color

135+brightBlack, brightRed, brightGreen, brightYellow :: Color

135−bright_blue, bright_magenta, bright_cyan, bright_white :: Color

136+brightBlue, brightMagenta, brightCyan, brightWhite :: Color

136−bright_black = ISOColor 8

137+brightBlack = ISOColor 8

137−bright_red = ISOColor 9

138+brightRed = ISOColor 9

138−bright_green = ISOColor 10

139+brightGreen = ISOColor 10

139−bright_yellow = ISOColor 11

140+brightYellow = ISOColor 11

140−bright_blue = ISOColor 12

141+brightBlue = ISOColor 12

141−bright_magenta= ISOColor 13

142+brightMagenta= ISOColor 13

142−bright_cyan = ISOColor 14

143+brightCyan = ISOColor 14

143−bright_white = ISOColor 15

144+brightWhite = ISOColor 15

144

145

145-- | Styles are represented as an 8 bit word. Each bit in the word is 1 if the style attribute

146-- | Styles are represented as an 8 bit word. Each bit in the word is 1 if the style attribute

146-- assigned to that bit should be applied and 0 if the style attribute should not be applied.

147-- assigned to that bit should be applied and 0 if the style attribute should not be applied.

@@ -152,7 +153,7 @@ type Style = Word8

152--

153--

153-- * underline

154-- * underline

154--

155--

155−-- * reverse_video

156+-- * reverseVideo

156--

157--

157-- * blink

158-- * blink

158--

159--

@@ -162,52 +163,55 @@ type Style = Word8

162--

163--

163-- ( The invisible, protect, and altcharset display attributes some terminals support are not

164-- ( The invisible, protect, and altcharset display attributes some terminals support are not

164-- supported via VTY.)

165-- supported via VTY.)

165−standout, underline, reverse_video, blink, dim, bold :: Style

166+standout, underline, reverseVideo, blink, dim, bold :: Style

166standout = 0x01

167standout = 0x01

167underline = 0x02

168underline = 0x02

168−reverse_video = 0x04

169+reverseVideo = 0x04

169blink = 0x08

170blink = 0x08

170dim = 0x10

171dim = 0x10

171bold = 0x20

172bold = 0x20

172

173

173−default_style_mask :: Style

174+defaultStyleMask :: Style

174−default_style_mask = 0x00

175+defaultStyleMask = 0x00

175

176

176−style_mask :: Attr -> Word8

177+styleMask :: Attr -> Word8

177−style_mask attr

178+styleMask attr

178− = case attr_style attr of

179+ = case attrStyle attr of

179 Default -> 0

180 Default -> 0

180 KeepCurrent -> 0

181 KeepCurrent -> 0

181 SetTo v -> v

182 SetTo v -> v

182

183

183-- | true if the given Style value has the specified Style set.

184-- | true if the given Style value has the specified Style set.

184−has_style :: Style -> Style -> Bool

185+hasStyle :: Style -> Style -> Bool

185−has_style s bit_mask = ( s .&. bit_mask ) /= 0

186+hasStyle s bit_mask = ( s .&. bit_mask ) /= 0

186

187

187-- | Set the foreground color of an `Attr'.

188-- | Set the foreground color of an `Attr'.

188−with_fore_color :: Attr -> Color -> Attr

189+withForeColor :: Attr -> Color -> Attr

189−with_fore_color attr c = attr { attr_fore_color = SetTo c }

190+withForeColor attr c = attr { attrForeColor = SetTo c }

190

191

191-- | Set the background color of an `Attr'.

192-- | Set the background color of an `Attr'.

192−with_back_color :: Attr -> Color -> Attr

193+withBackColor :: Attr -> Color -> Attr

193−with_back_color attr c = attr { attr_back_color = SetTo c }

194+withBackColor attr c = attr { attrBackColor = SetTo c }

194

195

195-- | Add the given style attribute

196-- | Add the given style attribute

196−with_style :: Attr -> Style -> Attr

197+withStyle :: Attr -> Style -> Attr

197−with_style attr style_flag = attr { attr_style = SetTo $ style_mask attr .|. style_flag }

198+withStyle attr style_flag = attr { attrStyle = SetTo $ styleMask attr .|. style_flag }

198

199

199-- | Sets the style, background color and foreground color to the default values for the terminal.

200-- | Sets the style, background color and foreground color to the default values for the terminal.

200-- There is no easy way to determine what the default background and foreground colors are.

201-- There is no easy way to determine what the default background and foreground colors are.

201−def_attr :: Attr

202+defAttr :: Attr

202−def_attr = Attr Default Default Default

203+defAttr = Attr Default Default Default

204+

205+instance Default Attr where

206+ def = defAttr

203

207

204-- | Keeps the style, background color and foreground color that was previously set. Used to

208-- | Keeps the style, background color and foreground color that was previously set. Used to

205-- override some part of the previous style.

209-- override some part of the previous style.

206--

210--

207−-- EG: current_style `with_fore_color` bright_magenta

211+-- EG: current_style `withForeColor` brightMagenta

208--

212--

209-- Would be the currently applied style (be it underline, bold, etc) but with the foreground color

213-- Would be the currently applied style (be it underline, bold, etc) but with the foreground color

210−-- set to bright_magenta.

214+-- set to brightMagenta.

211−current_attr :: Attr

215+currentAttr :: Attr

212−current_attr = Attr KeepCurrent KeepCurrent KeepCurrent

216+currentAttr = Attr KeepCurrent KeepCurrent KeepCurrent

213

217

src/Graphics/Vty/Attributes/Color240.hs+3−3

@@ -11,9 +11,9 @@ import Text.Printf

11--

12-- generated from 256colres.pl which is forked from xterm 256colres.pl

13-- todo: all values get clamped high.

14−rgb_color :: Integral i => i -> i -> i -> Color

14+rgbColor :: Integral i => i -> i -> i -> Color

15−rgb_color r g b

15+rgbColor r g b

16− | r < 0 && g < 0 && b < 0 = error "rgb_color with negative color component intensity"

16+ | r < 0 && g < 0 && b < 0 = error "rgbColor with negative color component intensity"

17 | r == 8 && g == 8 && b == 8 = Color240 216

18 | r == 18 && g == 18 && b == 18 = Color240 217

19 | r == 28 && g == 28 && b == 28 = Color240 218

src/Graphics/Vty/Debug.hs+14−14

@@ -12,29 +12,29 @@ import Graphics.Vty.Span

13import qualified Data.Vector as Vector

15−row_ops_effected_columns :: DisplayOps -> [Int]

15+rowOpsEffectedColumns :: DisplayOps -> [Int]

16−row_ops_effected_columns ops

16+rowOpsEffectedColumns ops

17− = Vector.toList $ Vector.map span_ops_effected_columns ops

17+ = Vector.toList $ Vector.map spanOpsEffectedColumns ops

19−all_spans_have_width :: DisplayOps -> Int -> Bool

19+allSpansHaveWidth :: DisplayOps -> Int -> Bool

20−all_spans_have_width ops expected

20+allSpansHaveWidth ops expected

21− = all (== expected) $ Vector.toList $ Vector.map span_ops_effected_columns ops

21+ = all (== expected) $ Vector.toList $ Vector.map spanOpsEffectedColumns ops

23−span_ops_effected_rows :: DisplayOps -> Int

23+spanOpsEffectedRows :: DisplayOps -> Int

24−span_ops_effected_rows ops

24+spanOpsEffectedRows ops

25 = toEnum $ length (filter (not . null . Vector.toList) (Vector.toList ops))

27type SpanConstructLog = [SpanConstructEvent]

28data SpanConstructEvent = SpanSetAttr Attr

30−is_set_attr :: Attr -> SpanConstructEvent -> Bool

30+isSetAttr :: Attr -> SpanConstructEvent -> Bool

31−is_set_attr expected_attr (SpanSetAttr in_attr)

31+isSetAttr expectedAttr (SpanSetAttr inAttr)

32− | in_attr == expected_attr = True

32+ | inAttr == expectedAttr = True

33−is_set_attr _attr _event = False

33+isSetAttr _attr _event = False

35data MockWindow = MockWindow Int Int

36 deriving (Show, Eq)

38−region_for_window :: MockWindow -> DisplayRegion

38+regionForWindow :: MockWindow -> DisplayRegion

39−region_for_window (MockWindow w h) = (w,h)

39+regionForWindow (MockWindow w h) = (w,h)

src/Graphics/Vty/Debug/Image.hs+10−10

@@ -6,26 +6,26 @@ type ImageConstructLog = [ImageConstructEvent]

6data ImageConstructEvent = ImageConstructEvent

7 deriving ( Show, Eq )

9−forward_image_ops :: [Image -> Image]

9+forwardImageOps :: [Image -> Image]

10−forward_image_ops = map forward_transform debug_image_ops

10+forwardImageOps = map forwardTransform debugImageOps

12−forward_transform, reverse_transform :: ImageOp -> (Image -> Image)

12+forwardTransform, reverseTransform :: ImageOp -> (Image -> Image)

14−forward_transform (ImageOp f _) = f

14+forwardTransform (ImageOp f _) = f

15−reverse_transform (ImageOp _ r) = r

15+reverseTransform (ImageOp _ r) = r

17data ImageOp = ImageOp ImageEndo ImageEndo

18type ImageEndo = Image -> Image

20−debug_image_ops :: [ImageOp]

20+debugImageOps :: [ImageOp]

21−debug_image_ops =

21+debugImageOps =

22− [ id_image_op

22+ [ idImageOp

23 -- , render_single_column_char_op

24 -- , render_double_column_char_op

25 ]

27−id_image_op :: ImageOp

27+idImageOp :: ImageOp

28−id_image_op = ImageOp id id

28+idImageOp = ImageOp id id

30-- render_char_op :: ImageOp

31-- render_char_op = ImageOp id id

src/Graphics/Vty/DisplayAttributes.hs+42−42

@@ -12,18 +12,18 @@ import Data.Monoid (Monoid(..), mconcat)

12-- attributes as an Attr produces a FixedAttr that represents the current display attributes. This

13-- is done by using the previously applied display attributes to remove the "KeepCurrent"

14-- abstraction.

15−fix_display_attr :: FixedAttr -> Attr -> FixedAttr

15+fixDisplayAttr :: FixedAttr -> Attr -> FixedAttr

16−fix_display_attr fattr attr

16+fixDisplayAttr fattr attr

17− = FixedAttr (fix_style (fixed_style fattr) (attr_style attr))

17+ = FixedAttr (fixStyle (fixedStyle fattr) (attrStyle attr))

18− (fix_color (fixed_fore_color fattr) (attr_fore_color attr))

18+ (fixColor (fixedForeColor fattr) (attrForeColor attr))

19− (fix_color (fixed_back_color fattr) (attr_back_color attr))

19+ (fixColor (fixedBackColor fattr) (attrBackColor attr))

20 where

21− fix_style _s Default = default_style_mask

21+ fixStyle _s Default = defaultStyleMask

22− fix_style s KeepCurrent = s

22+ fixStyle s KeepCurrent = s

23− fix_style _s (SetTo new_style) = new_style

23+ fixStyle _s (SetTo newStyle) = newStyle

24− fix_color _c Default = Nothing

24+ fixColor _c Default = Nothing

25− fix_color c KeepCurrent = c

25+ fixColor c KeepCurrent = c

26− fix_color _c (SetTo c) = Just c

26+ fixColor _c (SetTo c) = Just c

28-- | difference between two display attributes. Used in the calculation of the operations required

29-- to go from one display attribute to the next.

@@ -32,34 +32,34 @@ fix_display_attr fattr attr

32-- This turned out to be very expensive: A *lot* more data would be sent to the terminal than

33-- required.

34data DisplayAttrDiff = DisplayAttrDiff

35− { style_diffs :: [StyleStateChange]

35+ { styleDiffs :: [StyleStateChange]

36− , fore_color_diff :: DisplayColorDiff

36+ , foreColorDiff :: DisplayColorDiff

37− , back_color_diff :: DisplayColorDiff

37+ , backColorDiff :: DisplayColorDiff

38 }

39 deriving (Show)

41instance Monoid DisplayAttrDiff where

42 mempty = DisplayAttrDiff [] NoColorChange NoColorChange

43 mappend d_0 d_1 =

44− let ds = simplify_style_diffs (style_diffs d_0) (style_diffs d_1)

44+ let ds = simplifyStyleDiffs (styleDiffs d_0) (styleDiffs d_1)

45− fcd = simplify_color_diffs (fore_color_diff d_0) (fore_color_diff d_1)

45+ fcd = simplifyColorDiffs (foreColorDiff d_0) (foreColorDiff d_1)

46− bcd = simplify_color_diffs (back_color_diff d_0) (back_color_diff d_1)

46+ bcd = simplifyColorDiffs (backColorDiff d_0) (backColorDiff d_1)

47 in DisplayAttrDiff ds fcd bcd

49-- | Used in the computation of a final style attribute change.

50--

51-- TODO(corey): not really a simplify but a monoid instance.

52−simplify_style_diffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]

52+simplifyStyleDiffs :: [StyleStateChange] -> [StyleStateChange] -> [StyleStateChange]

53−simplify_style_diffs cs_0 cs_1 = cs_0 `mappend` cs_1

53+simplifyStyleDiffs cs_0 cs_1 = cs_0 `mappend` cs_1

55-- | Consider two display color attributes diffs. What display color attribute diff are these

56-- equivalent to?

57--

58-- TODO(corey): not really a simplify but a monoid instance.

59−simplify_color_diffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff

59+simplifyColorDiffs :: DisplayColorDiff -> DisplayColorDiff -> DisplayColorDiff

60−simplify_color_diffs _cd ColorToDefault = ColorToDefault

60+simplifyColorDiffs _cd ColorToDefault = ColorToDefault

61−simplify_color_diffs cd NoColorChange = cd

61+simplifyColorDiffs cd NoColorChange = cd

62−simplify_color_diffs _cd (SetColor !c) = SetColor c

62+simplifyColorDiffs _cd (SetColor !c) = SetColor c

64-- | Difference between two display color attribute changes.

65data DisplayColorDiff

@@ -87,33 +87,33 @@ data StyleStateChange

88-- | Determines the diff between two display&color attributes. This diff determines the operations

89-- that actually get output to the terminal.

90−display_attr_diffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff

90+displayAttrDiffs :: FixedAttr -> FixedAttr -> DisplayAttrDiff

91−display_attr_diffs attr attr' = DisplayAttrDiff

91+displayAttrDiffs attr attr' = DisplayAttrDiff

92− { style_diffs = diff_styles (fixed_style attr) (fixed_style attr')

92+ { styleDiffs = diffStyles (fixedStyle attr) (fixedStyle attr')

93− , fore_color_diff = diff_color (fixed_fore_color attr) (fixed_fore_color attr')

93+ , foreColorDiff = diffColor (fixedForeColor attr) (fixedForeColor attr')

94− , back_color_diff = diff_color (fixed_back_color attr) (fixed_back_color attr')

94+ , backColorDiff = diffColor (fixedBackColor attr) (fixedBackColor attr')

95 }

97−diff_color :: Maybe Color -> Maybe Color -> DisplayColorDiff

97+diffColor :: Maybe Color -> Maybe Color -> DisplayColorDiff

98−diff_color Nothing (Just c') = SetColor c'

98+diffColor Nothing (Just c') = SetColor c'

99−diff_color (Just c) (Just c')

99+diffColor (Just c) (Just c')

100 | c == c' = NoColorChange

101 | otherwise = SetColor c'

102−diff_color Nothing Nothing = NoColorChange

102+diffColor Nothing Nothing = NoColorChange

103−diff_color (Just _) Nothing = ColorToDefault

103+diffColor (Just _) Nothing = ColorToDefault

104

105−diff_styles :: Style -> Style -> [StyleStateChange]

105+diffStyles :: Style -> Style -> [StyleStateChange]

106−diff_styles prev cur

106+diffStyles prev cur

107 = mconcat

108− [ style_diff standout ApplyStandout RemoveStandout

108+ [ styleDiff standout ApplyStandout RemoveStandout

109− , style_diff underline ApplyUnderline RemoveUnderline

109+ , styleDiff underline ApplyUnderline RemoveUnderline

110− , style_diff reverse_video ApplyReverseVideo RemoveReverseVideo

110+ , styleDiff reverseVideo ApplyReverseVideo RemoveReverseVideo

111− , style_diff blink ApplyBlink RemoveBlink

111+ , styleDiff blink ApplyBlink RemoveBlink

112− , style_diff dim ApplyDim RemoveDim

112+ , styleDiff dim ApplyDim RemoveDim

113− , style_diff bold ApplyBold RemoveBold

113+ , styleDiff bold ApplyBold RemoveBold

114 ]

115 where

116− style_diff s sm rm

116+ styleDiff s sm rm

117 = case (0 == prev .&. s, 0 == cur .&. s) of

118 -- not set in either

119 (True, True) -> []

src/Graphics/Vty/Image.hs+122−122

@@ -4,41 +4,41 @@

4{-# LANGUAGE DisambiguateRecordFields #-}

5module Graphics.Vty.Image ( DisplayText

6 , Image

7− , image_width

7+ , imageWidth

8− , image_height

8+ , imageHeight

9− , horiz_join

9+ , horizJoin

10 , (<|>)

11− , vert_join

11+ , vertJoin

12 , (<->)

13− , horiz_cat

13+ , horizCat

14− , vert_cat

14+ , vertCat

15− , background_fill

15+ , backgroundFill

16 , text

17 , text'

18 , char

19 , string

20− , iso_10646_string

20+ , iso10646String

21− , utf8_string

21+ , utf8String

22− , utf8_bytestring

22+ , utf8Bytestring

23− , utf8_bytestring'

23+ , utf8Bytestring'

24− , char_fill

24+ , charFill

25− , empty_image

25+ , emptyImage

26− , safe_wcwidth

26+ , safeWcwidth

27− , safe_wcswidth

27+ , safeWcswidth

28 , wcwidth

29 , wcswidth

30 , crop

31− , crop_right

31+ , cropRight

32− , crop_left

32+ , cropLeft

33− , crop_bottom

33+ , cropBottom

34− , crop_top

34+ , cropTop

35 , pad

36 , resize

37− , resize_width

37+ , resizeWidth

38− , resize_height

38+ , resizeHeight

39 , translate

40− , translate_x

40+ , translateX

41− , translate_y

41+ , translateY

42 -- | The possible display attributes used in constructing an `Image`.

43 , module Graphics.Vty.Attributes

44 )

@@ -60,52 +60,52 @@ infixr 5 <|>

60infixr 4 <->

62-- | An area of the picture's bacground (See Background) of w columns and h rows.

63−background_fill :: Int -> Int -> Image

63+backgroundFill :: Int -> Int -> Image

64−background_fill w h

64+backgroundFill w h

65 | w == 0 = EmptyImage

66 | h == 0 = EmptyImage

67 | otherwise = BGFill w h

69−-- | Combines two images horizontally. Alias for horiz_join

69+-- | Combines two images horizontally. Alias for horizJoin

70--

71-- infixr 5

72(<|>) :: Image -> Image -> Image

73−(<|>) = horiz_join

73+(<|>) = horizJoin

75−-- | Combines two images vertically. Alias for vert_join

75+-- | Combines two images vertically. Alias for vertJoin

76--

77-- infixr 4

78(<->) :: Image -> Image -> Image

79−(<->) = vert_join

79+(<->) = vertJoin

81-- | Compose any number of images horizontally.

82−horiz_cat :: [Image] -> Image

82+horizCat :: [Image] -> Image

83−horiz_cat = foldr horiz_join EmptyImage

83+horizCat = foldr horizJoin EmptyImage

85-- | Compose any number of images vertically.

86−vert_cat :: [Image] -> Image

86+vertCat :: [Image] -> Image

87−vert_cat = foldr vert_join EmptyImage

87+vertCat = foldr vertJoin EmptyImage

89-- | A Data.Text.Lazy value

90text :: Attr -> TL.Text -> Image

91text a txt

92 | TL.length txt == 0 = EmptyImage

93− | otherwise = let display_width = safe_wcswidth (TL.unpack txt)

93+ | otherwise = let displayWidth = safeWcswidth (TL.unpack txt)

94− in HorizText a txt display_width (fromIntegral $! TL.length txt)

94+ in HorizText a txt displayWidth (fromIntegral $! TL.length txt)

96-- | A Data.Text value

97text' :: Attr -> T.Text -> Image

98text' a txt

99 | T.length txt == 0 = EmptyImage

100− | otherwise = let display_width = safe_wcswidth (T.unpack txt)

100+ | otherwise = let displayWidth = safeWcswidth (T.unpack txt)

101− in HorizText a (TL.fromStrict txt) display_width (T.length txt)

101+ in HorizText a (TL.fromStrict txt) displayWidth (T.length txt)

102

103-- | an image of a single character. This is a standard Haskell 31-bit character assumed to be in

104-- the ISO-10646 encoding.

105char :: Attr -> Char -> Image

106char a c =

107− let display_width = safe_wcwidth c

107+ let displayWidth = safeWcwidth c

108− in HorizText a (TL.singleton c) display_width 1

108+ in HorizText a (TL.singleton c) displayWidth 1

109

110-- | A string of characters layed out on a single row with the same display attribute. The string is

111-- assumed to be a sequence of ISO-10646 characters.

@@ -114,51 +114,51 @@ char a c =

114-- UTF-8 encoded source file, for example, may be represented as a ISO-10646 string.

115-- That is, I think, the case with GHC 6.10. This means, for the most part, you don't need to worry

116-- about the encoding format when outputting string literals. Just provide the string literal

117−-- directly to iso_10646_string or string.

117+-- directly to iso10646String or string.

118--

119−iso_10646_string :: Attr -> String -> Image

119+iso10646String :: Attr -> String -> Image

120−iso_10646_string a str =

120+iso10646String a str =

121− let display_width = safe_wcswidth str

121+ let displayWidth = safeWcswidth str

122− in HorizText a (TL.pack str) display_width (length str)

122+ in HorizText a (TL.pack str) displayWidth (length str)

123

124−-- | Alias for iso_10646_string. Since the usual case is that a literal string like "foo" is

124+-- | Alias for iso10646String. Since the usual case is that a literal string like "foo" is

125-- represented internally as a list of ISO 10646 31 bit characters.

126--

127-- Note: Keep in mind that GHC will compile source encoded as UTF-8 but the literal strings, while

128-- UTF-8 encoded in the source, will be transcoded to a ISO 10646 31 bit characters runtime

129-- representation.

130string :: Attr -> String -> Image

131−string = iso_10646_string

131+string = iso10646String

132

133-- | A string of characters layed out on a single row. The input is assumed to be the bytes for

134-- UTF-8 encoded text.

135−utf8_string :: Attr -> [Word8] -> Image

135+utf8String :: Attr -> [Word8] -> Image

136−utf8_string a bytes = utf8_bytestring a (BL.pack bytes)

136+utf8String a bytes = utf8Bytestring a (BL.pack bytes)

137

138-- | Renders a UTF-8 encoded lazy bytestring.

139−utf8_bytestring :: Attr -> BL.ByteString -> Image

139+utf8Bytestring :: Attr -> BL.ByteString -> Image

140−utf8_bytestring a bs = text a (TL.decodeUtf8 bs)

140+utf8Bytestring a bs = text a (TL.decodeUtf8 bs)

141

142-- | Renders a UTF-8 encoded strict bytestring.

143−utf8_bytestring' :: Attr -> B.ByteString -> Image

143+utf8Bytestring' :: Attr -> B.ByteString -> Image

144−utf8_bytestring' a bs = text' a (T.decodeUtf8 bs)

144+utf8Bytestring' a bs = text' a (T.decodeUtf8 bs)

145

146-- | creates a fill of the specified character. The dimensions are in number of characters wide and

147-- number of rows high.

148−char_fill :: Integral d => Attr -> Char -> d -> d -> Image

148+charFill :: Integral d => Attr -> Char -> d -> d -> Image

149−char_fill _a _c 0 _h = EmptyImage

149+charFill _a _c 0 _h = EmptyImage

150−char_fill _a _c _w 0 = EmptyImage

150+charFill _a _c _w 0 = EmptyImage

151−char_fill a c w h =

151+charFill a c w h =

152− vert_cat $ replicate (fromIntegral h) $ HorizText a txt display_width char_width

152+ vertCat $ replicate (fromIntegral h) $ HorizText a txt displayWidth char_width

153 where

154 txt = TL.replicate (fromIntegral w) (TL.singleton c)

155− display_width = safe_wcwidth c * (fromIntegral w)

155+ displayWidth = safeWcwidth c * (fromIntegral w)

156 char_width = fromIntegral w

157

158-- | The empty image. Useful for fold combinators. These occupy no space nor define any display

159-- attributes.

160−empty_image :: Image

160+emptyImage :: Image

161−empty_image = EmptyImage

161+emptyImage = EmptyImage

162

163-- | pad the given image. This adds background character fills to the left, top, right, bottom.

164-- The pad values are how many display columns or rows to add.

@@ -171,38 +171,38 @@ pad in_l in_t in_r in_b in_image

171 -- TODO: uh.

172 go 0 0 0 0 i = i

173 go 0 0 0 b i = VertJoin i (BGFill w b) w h

174− where w = image_width i

174+ where w = imageWidth i

175− h = image_height i + b

175+ h = imageHeight i + b

176 go 0 0 r b i = go 0 0 0 b $ HorizJoin i (BGFill r h) w h

177− where w = image_width i + r

177+ where w = imageWidth i + r

178− h = image_height i

178+ h = imageHeight i

179 go 0 t r b i = go 0 0 r b $ VertJoin (BGFill w t) i w h

180− where w = image_width i

180+ where w = imageWidth i

181− h = image_height i + t

181+ h = imageHeight i + t

182 go l t r b i = go 0 t r b $ HorizJoin (BGFill l h) i w h

183− where w = image_width i + l

183+ where w = imageWidth i + l

184− h = image_height i

184+ h = imageHeight i

185

186-- | translates an image by padding or cropping the top and left.

187--

188-- This can have an unexpected effect: Translating an image to less than (0,0) then to greater than

189-- (0,0) will crop the image.

190translate :: Int -> Int -> Image -> Image

191−translate x y i = translate_x x (translate_y y i)

191+translate x y i = translateX x (translateY y i)

192

193-- | translates an image by padding or cropping the left

194−translate_x :: Int -> Image -> Image

194+translateX :: Int -> Image -> Image

195−translate_x x i

195+translateX x i

196− | x < 0 = let s = abs x in CropLeft i s (image_width i - s) (image_height i)

196+ | x < 0 = let s = abs x in CropLeft i s (imageWidth i - s) (imageHeight i)

197 | x == 0 = i

198− | otherwise = let h = image_height i in HorizJoin (BGFill x h) i (image_width i + x) h

198+ | otherwise = let h = imageHeight i in HorizJoin (BGFill x h) i (imageWidth i + x) h

199

200-- | translates an image by padding or cropping the top

201−translate_y :: Int -> Image -> Image

201+translateY :: Int -> Image -> Image

202−translate_y y i

202+translateY y i

203− | y < 0 = let s = abs y in CropTop i s (image_width i) (image_height i - s)

203+ | y < 0 = let s = abs y in CropTop i s (imageWidth i) (imageHeight i - s)

204 | y == 0 = i

205− | otherwise = let w = image_width i in VertJoin (BGFill w y) i w (image_height i + y)

205+ | otherwise = let w = imageWidth i in VertJoin (BGFill w y) i w (imageHeight i + y)

206

207-- | Ensure an image is no larger than the provided size. If the image is larger then crop the right

208-- or bottom.

@@ -212,94 +212,94 @@ translate_y y i

212crop :: Int -> Int -> Image -> Image

213crop 0 _ _ = EmptyImage

214crop _ 0 _ = EmptyImage

215−crop w h i = crop_bottom h (crop_right w i)

215+crop w h i = cropBottom h (cropRight w i)

216

217-- | crop the display height. If the image is less than or equal in height then this operation has

218-- no effect. Otherwise the image is cropped from the bottom.

219−crop_bottom :: Int -> Image -> Image

219+cropBottom :: Int -> Image -> Image

220−crop_bottom 0 _ = EmptyImage

220+cropBottom 0 _ = EmptyImage

221−crop_bottom h in_i

221+cropBottom h in_i

222 | h < 0 = error "cannot crop height to less than zero"

223 | otherwise = go in_i

224 where

225 go EmptyImage = EmptyImage

226− go i@(CropBottom {cropped_image, output_width, output_height})

226+ go i@(CropBottom {croppedImage, outputWidth, outputHeight})

227− | output_height <= h = i

227+ | outputHeight <= h = i

228− | otherwise = CropBottom cropped_image output_width h

228+ | otherwise = CropBottom croppedImage outputWidth h

229 go i

230− | h >= image_height i = i

230+ | h >= imageHeight i = i

231− | otherwise = CropBottom i (image_width i) h

231+ | otherwise = CropBottom i (imageWidth i) h

232

233-- | ensure the image is no wider than the given width. If the image is wider then crop the right

234-- side.

235−crop_right :: Int -> Image -> Image

235+cropRight :: Int -> Image -> Image

236−crop_right 0 _ = EmptyImage

236+cropRight 0 _ = EmptyImage

237−crop_right w in_i

237+cropRight w in_i

238 | w < 0 = error "cannot crop width to less than zero"

239 | otherwise = go in_i

240 where

241 go EmptyImage = EmptyImage

242− go i@(CropRight {cropped_image, output_width, output_height})

242+ go i@(CropRight {croppedImage, outputWidth, outputHeight})

243− | output_width <= w = i

243+ | outputWidth <= w = i

244− | otherwise = CropRight cropped_image w output_height

244+ | otherwise = CropRight croppedImage w outputHeight

245 go i

246− | w >= image_width i = i

246+ | w >= imageWidth i = i

247− | otherwise = CropRight i w (image_height i)

247+ | otherwise = CropRight i w (imageHeight i)

248

249-- | ensure the image is no wider than the given width. If the image is wider then crop the left

250-- side.

251−crop_left :: Int -> Image -> Image

251+cropLeft :: Int -> Image -> Image

252−crop_left 0 _ = EmptyImage

252+cropLeft 0 _ = EmptyImage

253−crop_left w in_i

253+cropLeft w in_i

254 | w < 0 = error "cannot crop the width to less than zero"

255 | otherwise = go in_i

256 where

257 go EmptyImage = EmptyImage

258− go i@(CropLeft {cropped_image, left_skip, output_width, output_height})

258+ go i@(CropLeft {croppedImage, leftSkip, outputWidth, outputHeight})

259− | output_width <= w = i

259+ | outputWidth <= w = i

260 | otherwise =

261− let left_skip' = left_skip + output_width - w

261+ let leftSkip' = leftSkip + outputWidth - w

262− in CropLeft cropped_image left_skip' w output_height

262+ in CropLeft croppedImage leftSkip' w outputHeight

263 go i

264− | image_width i <= w = i

264+ | imageWidth i <= w = i

265− | otherwise = CropLeft i (image_width i - w) w (image_height i)

265+ | otherwise = CropLeft i (imageWidth i - w) w (imageHeight i)

266

267-- | crop the display height. If the image is less than or equal in height then this operation has

268-- no effect. Otherwise the image is cropped from the top.

269−crop_top :: Int -> Image -> Image

269+cropTop :: Int -> Image -> Image

270−crop_top 0 _ = EmptyImage

270+cropTop 0 _ = EmptyImage

271−crop_top h in_i

271+cropTop h in_i

272 | h < 0 = error "cannot crop the height to less than zero"

273 | otherwise = go in_i

274 where

275 go EmptyImage = EmptyImage

276− go i@(CropTop {cropped_image, top_skip, output_width, output_height})

276+ go i@(CropTop {croppedImage, topSkip, outputWidth, outputHeight})

277− | output_height <= h = i

277+ | outputHeight <= h = i

278− | otherwise =

278+ | otherwise =

279− let top_skip' = top_skip + output_height - h

279+ let topSkip' = topSkip + outputHeight - h

280− in CropTop cropped_image top_skip' output_width h

280+ in CropTop croppedImage topSkip' outputWidth h

281 go i

282− | image_height i <= h = i

282+ | imageHeight i <= h = i

283− | otherwise = CropTop i (image_height i - h) (image_width i) h

283+ | otherwise = CropTop i (imageHeight i - h) (imageWidth i) h

284

285-- | Generic resize. Pads and crops as required to assure the given display width and height.

286-- This is biased to pad/crop the right and bottom.

287resize :: Int -> Int -> Image -> Image

288−resize w h i = resize_height h (resize_width w i)

288+resize w h i = resizeHeight h (resizeWidth w i)

289

290-- | Resize the width. Pads and crops as required to assure the given display width.

291-- This is biased to pad/crop the right.

292−resize_width :: Int -> Image -> Image

292+resizeWidth :: Int -> Image -> Image

293−resize_width w i = case w `compare` image_width i of

293+resizeWidth w i = case w `compare` imageWidth i of

294− LT -> crop_right w i

294+ LT -> cropRight w i

295 EQ -> i

296− GT -> i <|> BGFill (w - image_width i) (image_height i)

296+ GT -> i <|> BGFill (w - imageWidth i) (imageHeight i)

297

298-- | Resize the height. Pads and crops as required to assure the given display height.

299-- This is biased to pad/crop the bottom.

300−resize_height :: Int -> Image -> Image

300+resizeHeight :: Int -> Image -> Image

301−resize_height h i = case h `compare` image_height i of

301+resizeHeight h i = case h `compare` imageHeight i of

302− LT -> crop_bottom h i

302+ LT -> cropBottom h i

303 EQ -> i

304− GT -> i <-> BGFill (image_width i) (h - image_height i)

304+ GT -> i <-> BGFill (imageWidth i) (h - imageHeight i)

305

src/Graphics/Vty/Image/Internal.hs+136−136

@@ -22,21 +22,21 @@ type DisplayText = TL.Text

22-- TODO: store a skip list in HorizText(?)

23-- TODO: represent display strings containing chars that are not 1 column chars as a separate

24-- display string value?

25−clip_text :: DisplayText -> Int -> Int -> DisplayText

25+clipText :: DisplayText -> Int -> Int -> DisplayText

26−clip_text txt left_skip right_clip =

26+clipText txt leftSkip rightClip =

27 -- CPS would clarify this I think

28− let (to_drop,pad_prefix) = clip_for_char_width left_skip txt 0

28+ let (toDrop,padPrefix) = clipForCharWidth leftSkip txt 0

29− txt' = if pad_prefix then TL.cons '…' (TL.drop (to_drop+1) txt) else TL.drop to_drop txt

29+ txt' = if padPrefix then TL.cons '…' (TL.drop (toDrop+1) txt) else TL.drop toDrop txt

30− (to_take,pad_suffix) = clip_for_char_width right_clip txt' 0

30+ (toTake,padSuffix) = clipForCharWidth rightClip txt' 0

31− txt'' = TL.append (TL.take to_take txt') (if pad_suffix then TL.singleton '…' else TL.empty)

31+ txt'' = TL.append (TL.take toTake txt') (if padSuffix then TL.singleton '…' else TL.empty)

32− clip_for_char_width 0 _ n = (n, False)

32+ clipForCharWidth 0 _ n = (n, False)

33− clip_for_char_width w t n

33+ clipForCharWidth w t n

34 | TL.null t = (n, False)

35 | w < cw = (n, True)

36 | w == cw = (n+1, False)

37− | w > cw = clip_for_char_width (w - cw) (TL.tail t) (n + 1)

37+ | w > cw = clipForCharWidth (w - cw) (TL.tail t) (n + 1)

38− where cw = safe_wcwidth (TL.head t)

38+ where cw = safeWcwidth (TL.head t)

39− clip_for_char_width _ _ _ = error "clip_for_char_width applied to undefined"

39+ clipForCharWidth _ _ _ = error "clipForCharWidth applied to undefined"

40 in txt''

42-- | This is the internal representation of Images. Use the constructors in "Graphics.Vty.Image" to

@@ -57,70 +57,70 @@ data Image =

57 -- | A horizontal text span is always >= 1 column and has a row height of 1.

58 HorizText

59 { attr :: Attr

60− -- | The text to display. The display width of the text is always output_width.

60+ -- | The text to display. The display width of the text is always outputWidth.

61− , display_text :: DisplayText

61+ , displayText :: DisplayText

62 -- | The number of display columns for the text. Always > 0.

63− , output_width :: Int

63+ , outputWidth :: Int

64 -- | the number of characters in the text. Always > 0.

65− , char_width :: Int

65+ , charWidth :: Int

66 }

67 -- | A horizontal join can be constructed between any two images. However a HorizJoin instance is

68− -- required to be between two images of equal height. The horiz_join constructor adds background

68+ -- required to be between two images of equal height. The horizJoin constructor adds background

69 -- fills to the provided images that assure this is true for the HorizJoin value produced.

70 | HorizJoin

71− { part_left :: Image

71+ { partLeft :: Image

72− , part_right :: Image

72+ , partRight :: Image

73− , output_width :: Int -- ^ image_width part_left == image_width part_right. Always > 1

73+ , outputWidth :: Int -- ^ imageWidth partLeft == imageWidth partRight. Always > 1

74− , output_height :: Int -- ^ image_height part_left == image_height part_right. Always > 0

74+ , outputHeight :: Int -- ^ imageHeight partLeft == imageHeight partRight. Always > 0

75 }

76 -- | A veritical join can be constructed between any two images. However a VertJoin instance is

77− -- required to be between two images of equal width. The vert_join constructor adds background

77+ -- required to be between two images of equal width. The vertJoin constructor adds background

78 -- fills to the provides images that assure this is true for the VertJoin value produced.

79 | VertJoin

80− { part_top :: Image

80+ { partTop :: Image

81− , part_bottom :: Image

81+ , partBottom :: Image

82− , output_width :: Int -- ^ image_width part_top == image_width part_bottom. always > 0

82+ , outputWidth :: Int -- ^ imageWidth partTop == imageWidth partBottom. always > 0

83− , output_height :: Int -- ^ image_height part_top == image_height part_bottom. always > 1

83+ , outputHeight :: Int -- ^ imageHeight partTop == imageHeight partBottom. always > 1

84 }

85 -- | A background fill will be filled with the background char. The background char is

86 -- defined as a property of the Picture this Image is used to form.

87 | BGFill

88− { output_width :: Int -- ^ always > 0

88+ { outputWidth :: Int -- ^ always > 0

89− , output_height :: Int -- ^ always > 0

89+ , outputHeight :: Int -- ^ always > 0

90 }

91 -- | Crop an image horizontally to a size by reducing the size from the right.

92 | CropRight

93− { cropped_image :: Image

93+ { croppedImage :: Image

94− -- | Always < image_width cropped_image > 0

94+ -- | Always < imageWidth croppedImage > 0

95− , output_width :: Int

95+ , outputWidth :: Int

96− , output_height :: Int -- ^ image_height cropped_image

96+ , outputHeight :: Int -- ^ imageHeight croppedImage

97 }

98 -- | Crop an image horizontally to a size by reducing the size from the left.

99 | CropLeft

100− { cropped_image :: Image

100+ { croppedImage :: Image

101− -- | Always < image_width cropped_image > 0

101+ -- | Always < imageWidth croppedImage > 0

102− , left_skip :: Int

102+ , leftSkip :: Int

103− -- | Always < image_width cropped_image > 0

103+ -- | Always < imageWidth croppedImage > 0

104− , output_width :: Int

104+ , outputWidth :: Int

105− , output_height :: Int

105+ , outputHeight :: Int

106 }

107 -- | Crop an image vertically to a size by reducing the size from the bottom

108 | CropBottom

109− { cropped_image :: Image

109+ { croppedImage :: Image

110− -- | image_width cropped_image

110+ -- | imageWidth croppedImage

111− , output_width :: Int

111+ , outputWidth :: Int

112− -- | height image is cropped to. Always < image_height cropped_image > 0

112+ -- | height image is cropped to. Always < imageHeight croppedImage > 0

113− , output_height :: Int

113+ , outputHeight :: Int

114 }

115 -- | Crop an image vertically to a size by reducing the size from the top

116 | CropTop

117− { cropped_image :: Image

117+ { croppedImage :: Image

118− -- | Always < image_height cropped_image > 0

118+ -- | Always < imageHeight croppedImage > 0

119− , top_skip :: Int

119+ , topSkip :: Int

120− -- | image_width cropped_image

120+ -- | imageWidth croppedImage

121− , output_width :: Int

121+ , outputWidth :: Int

122− -- | Always < image_height cropped_image > 0

122+ -- | Always < imageHeight croppedImage > 0

123− , output_height :: Int

123+ , outputHeight :: Int

124 }

125 -- | The empty image

126 --

@@ -133,58 +133,58 @@ data Image =

133 deriving Eq

134

135instance Show Image where

136− show ( HorizText { attr, display_text, output_width, char_width } )

136+ show ( HorizText { attr, displayText, outputWidth, charWidth } )

137− = "HorizText " ++ show display_text

137+ = "HorizText " ++ show displayText

138 ++ "@(" ++ show attr ++ ","

139− ++ show output_width ++ ","

139+ ++ show outputWidth ++ ","

140− ++ show char_width ++ ")"

140+ ++ show charWidth ++ ")"

141− show ( BGFill { output_width, output_height } )

141+ show ( BGFill { outputWidth, outputHeight } )

142− = "BGFill (" ++ show output_width ++ "," ++ show output_height ++ ")"

142+ = "BGFill (" ++ show outputWidth ++ "," ++ show outputHeight ++ ")"

143− show ( HorizJoin { part_left = l, part_right = r, output_width = c } )

143+ show ( HorizJoin { partLeft = l, partRight = r, outputWidth = c } )

144 = "HorizJoin " ++ show c ++ " (" ++ show l ++ " <|> " ++ show r ++ ")"

145− show ( VertJoin { part_top = t, part_bottom = b, output_width = c, output_height = r } )

145+ show ( VertJoin { partTop = t, partBottom = b, outputWidth = c, outputHeight = r } )

146 = "VertJoin [" ++ show c ++ ", " ++ show r ++ "] (" ++ show t ++ ") <-> (" ++ show b ++ ")"

147− show ( CropRight { cropped_image, output_width, output_height } )

147+ show ( CropRight { croppedImage, outputWidth, outputHeight } )

148− = "CropRight [" ++ show output_width ++ "," ++ show output_height ++ "]"

148+ = "CropRight [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]"

149− ++ " (" ++ show cropped_image ++ ")"

149+ ++ " (" ++ show croppedImage ++ ")"

150− show ( CropLeft { cropped_image, left_skip, output_width, output_height } )

150+ show ( CropLeft { croppedImage, leftSkip, outputWidth, outputHeight } )

151− = "CropLeft [" ++ show left_skip ++ "," ++ show output_width ++ "," ++ show output_height ++ "]"

151+ = "CropLeft [" ++ show leftSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]"

152− ++ " (" ++ show cropped_image ++ ")"

152+ ++ " (" ++ show croppedImage ++ ")"

153− show ( CropBottom { cropped_image, output_width, output_height } )

153+ show ( CropBottom { croppedImage, outputWidth, outputHeight } )

154− = "CropBottom [" ++ show output_width ++ "," ++ show output_height ++ "]"

154+ = "CropBottom [" ++ show outputWidth ++ "," ++ show outputHeight ++ "]"

155− ++ " (" ++ show cropped_image ++ ")"

155+ ++ " (" ++ show croppedImage ++ ")"

156− show ( CropTop { cropped_image, top_skip, output_width, output_height } )

156+ show ( CropTop { croppedImage, topSkip, outputWidth, outputHeight } )

157− = "CropTop [" ++ show top_skip ++ "," ++ show output_width ++ "," ++ show output_height ++ "]"

157+ = "CropTop [" ++ show topSkip ++ "," ++ show outputWidth ++ "," ++ show outputHeight ++ "]"

158− ++ " (" ++ show cropped_image ++ ")"

158+ ++ " (" ++ show croppedImage ++ ")"

159 show ( EmptyImage ) = "EmptyImage"

160

161-- | Attempts to pretty print just the structure of an image.

162pp_image_structure :: Image -> String

163−pp_image_structure in_img = go 0 in_img

163+pp_image_structure inImg = go 0 inImg

164 where

165 go indent img = tab indent ++ pp indent img

166 tab indent = concat $ replicate indent " "

167− pp _ (HorizText {output_width}) = "HorizText(" ++ show output_width ++ ")"

167+ pp _ (HorizText {outputWidth}) = "HorizText(" ++ show outputWidth ++ ")"

168− pp _ (BGFill {output_width, output_height})

168+ pp _ (BGFill {outputWidth, outputHeight})

169− = "BGFill(" ++ show output_width ++ "," ++ show output_height ++ ")"

169+ = "BGFill(" ++ show outputWidth ++ "," ++ show outputHeight ++ ")"

170− pp i (HorizJoin {part_left = l, part_right = r, output_width = c})

170+ pp i (HorizJoin {partLeft = l, partRight = r, outputWidth = c})

171 = "HorizJoin(" ++ show c ++ ")\n" ++ go (i+1) l ++ "\n" ++ go (i+1) r

172− pp i (VertJoin {part_top = t, part_bottom = b, output_width = c, output_height = r})

172+ pp i (VertJoin {partTop = t, partBottom = b, outputWidth = c, outputHeight = r})

173 = "VertJoin(" ++ show c ++ ", " ++ show r ++ ")\n"

174 ++ go (i+1) t ++ "\n"

175 ++ go (i+1) b

176− pp i (CropRight {cropped_image, output_width, output_height})

176+ pp i (CropRight {croppedImage, outputWidth, outputHeight})

177− = "CropRight(" ++ show output_width ++ "," ++ show output_height ++ ")\n"

177+ = "CropRight(" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n"

178− ++ go (i+1) cropped_image

178+ ++ go (i+1) croppedImage

179− pp i (CropLeft {cropped_image, left_skip, output_width, output_height})

179+ pp i (CropLeft {croppedImage, leftSkip, outputWidth, outputHeight})

180− = "CropLeft(" ++ show left_skip ++ "->" ++ show output_width ++ "," ++ show output_height ++ ")\n"

180+ = "CropLeft(" ++ show leftSkip ++ "->" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n"

181− ++ go (i+1) cropped_image

181+ ++ go (i+1) croppedImage

182− pp i (CropBottom {cropped_image, output_width, output_height})

182+ pp i (CropBottom {croppedImage, outputWidth, outputHeight})

183− = "CropBottom(" ++ show output_width ++ "," ++ show output_height ++ ")\n"

183+ = "CropBottom(" ++ show outputWidth ++ "," ++ show outputHeight ++ ")\n"

184− ++ go (i+1) cropped_image

184+ ++ go (i+1) croppedImage

185− pp i (CropTop {cropped_image, top_skip, output_width, output_height})

185+ pp i (CropTop {croppedImage, topSkip, outputWidth, outputHeight})

186− = "CropTop("++ show output_width ++ "," ++ show top_skip ++ "->" ++ show output_height ++ ")\n"

186+ = "CropTop("++ show outputWidth ++ "," ++ show topSkip ++ "->" ++ show outputHeight ++ ")\n"

187− ++ go (i+1) cropped_image

187+ ++ go (i+1) croppedImage

188 pp _ EmptyImage = "EmptyImage"

189

190instance NFData Image where

@@ -199,37 +199,37 @@ instance NFData Image where

199 rnf (HorizText a s w cw) = a `seq` s `deepseq` w `seq` cw `seq` ()

200

201-- | The width of an Image. This is the number display columns the image will occupy.

202−image_width :: Image -> Int

202+imageWidth :: Image -> Int

203−image_width HorizText { output_width = w } = w

203+imageWidth HorizText { outputWidth = w } = w

204−image_width HorizJoin { output_width = w } = w

204+imageWidth HorizJoin { outputWidth = w } = w

205−image_width VertJoin { output_width = w } = w

205+imageWidth VertJoin { outputWidth = w } = w

206−image_width BGFill { output_width = w } = w

206+imageWidth BGFill { outputWidth = w } = w

207−image_width CropRight { output_width = w } = w

207+imageWidth CropRight { outputWidth = w } = w

208−image_width CropLeft { output_width = w } = w

208+imageWidth CropLeft { outputWidth = w } = w

209−image_width CropBottom { output_width = w } = w

209+imageWidth CropBottom { outputWidth = w } = w

210−image_width CropTop { output_width = w } = w

210+imageWidth CropTop { outputWidth = w } = w

211−image_width EmptyImage = 0

211+imageWidth EmptyImage = 0

212

213-- | The height of an Image. This is the number of display rows the image will occupy.

214−image_height :: Image -> Int

214+imageHeight :: Image -> Int

215−image_height HorizText {} = 1

215+imageHeight HorizText {} = 1

216−image_height HorizJoin { output_height = h } = h

216+imageHeight HorizJoin { outputHeight = h } = h

217−image_height VertJoin { output_height = h } = h

217+imageHeight VertJoin { outputHeight = h } = h

218−image_height BGFill { output_height = h } = h

218+imageHeight BGFill { outputHeight = h } = h

219−image_height CropRight { output_height = h } = h

219+imageHeight CropRight { outputHeight = h } = h

220−image_height CropLeft { output_height = h } = h

220+imageHeight CropLeft { outputHeight = h } = h

221−image_height CropBottom { output_height = h } = h

221+imageHeight CropBottom { outputHeight = h } = h

222−image_height CropTop { output_height = h } = h

222+imageHeight CropTop { outputHeight = h } = h

223−image_height EmptyImage = 0

223+imageHeight EmptyImage = 0

224

225-- | Append in the Monoid instance is equivalent to <->.

226instance Monoid Image where

227 mempty = EmptyImage

228− mappend = vert_join

228+ mappend = vertJoin

229

230-- | combines two images side by side

231--

232−-- Combines text chunks where possible. Assures output_width and output_height properties are not

232+-- Combines text chunks where possible. Assures outputWidth and outputHeight properties are not

233-- violated.

234--

235-- The result image will have a width equal to the sum of the two images width. And the height will

@@ -237,30 +237,30 @@ instance Monoid Image where

237-- missmatch will be filled with the background pattern.

238--

239-- TODO: the bg fill is biased towards top to bottom languages(?)

240−horiz_join :: Image -> Image -> Image

240+horizJoin :: Image -> Image -> Image

241−horiz_join EmptyImage i = i

241+horizJoin EmptyImage i = i

242−horiz_join i EmptyImage = i

242+horizJoin i EmptyImage = i

243−horiz_join i_0@(HorizText a_0 t_0 w_0 cw_0) i_1@(HorizText a_1 t_1 w_1 cw_1)

243+horizJoin i_0@(HorizText a_0 t_0 w_0 cw_0) i_1@(HorizText a_1 t_1 w_1 cw_1)

244 | a_0 == a_1 = HorizText a_0 (TL.append t_0 t_1) (w_0 + w_1) (cw_0 + cw_1)

245 -- TODO: assumes horiz text height is always 1

246 | otherwise = HorizJoin i_0 i_1 (w_0 + w_1) 1

247−horiz_join i_0 i_1

247+horizJoin i_0 i_1

248 -- If the images are of the same height then no padding is required

249 | h_0 == h_1 = HorizJoin i_0 i_1 w h_0

250 -- otherwise one of the images needs to be padded to the right size.

251 | h_0 < h_1 -- Pad i_0

252− = let pad_amount = h_1 - h_0

252+ = let padAmount = h_1 - h_0

253− in HorizJoin (VertJoin i_0 (BGFill w_0 pad_amount) w_0 h_1) i_1 w h_1

253+ in HorizJoin (VertJoin i_0 (BGFill w_0 padAmount) w_0 h_1) i_1 w h_1

254 | h_0 > h_1 -- Pad i_1

255− = let pad_amount = h_0 - h_1

255+ = let padAmount = h_0 - h_1

256− in HorizJoin i_0 (VertJoin i_1 (BGFill w_1 pad_amount) w_1 h_0) w h_0

256+ in HorizJoin i_0 (VertJoin i_1 (BGFill w_1 padAmount) w_1 h_0) w h_0

257 where

258− w_0 = image_width i_0

258+ w_0 = imageWidth i_0

259− w_1 = image_width i_1

259+ w_1 = imageWidth i_1

260 w = w_0 + w_1

261− h_0 = image_height i_0

261+ h_0 = imageHeight i_0

262− h_1 = image_height i_1

262+ h_1 = imageHeight i_1

263−horiz_join _ _ = error "horiz_join applied to undefined values."

263+horizJoin _ _ = error "horizJoin applied to undefined values."

264

265-- | combines two images vertically

266--

@@ -270,24 +270,24 @@ horiz_join _ _ = error "horiz_join applied to undefined values."

270-- pattern.

271--

272-- TODO: the bg fill is biased towards right to left languages(?)

273−vert_join :: Image -> Image -> Image

273+vertJoin :: Image -> Image -> Image

274−vert_join EmptyImage i = i

274+vertJoin EmptyImage i = i

275−vert_join i EmptyImage = i

275+vertJoin i EmptyImage = i

276−vert_join i_0 i_1

276+vertJoin i_0 i_1

277 -- If the images are of the same width then no background padding is required

278 | w_0 == w_1 = VertJoin i_0 i_1 w_0 h

279 -- Otherwise one of the images needs to be padded to the size of the other image.

280 | w_0 < w_1

281− = let pad_amount = w_1 - w_0

281+ = let padAmount = w_1 - w_0

282− in VertJoin (HorizJoin i_0 (BGFill pad_amount h_0) w_1 h_0) i_1 w_1 h

282+ in VertJoin (HorizJoin i_0 (BGFill padAmount h_0) w_1 h_0) i_1 w_1 h

283 | w_0 > w_1

284− = let pad_amount = w_0 - w_1

284+ = let padAmount = w_0 - w_1

285− in VertJoin i_0 (HorizJoin i_1 (BGFill pad_amount h_1) w_0 h_1) w_0 h

285+ in VertJoin i_0 (HorizJoin i_1 (BGFill padAmount h_1) w_0 h_1) w_0 h

286 where

287− w_0 = image_width i_0

287+ w_0 = imageWidth i_0

288− w_1 = image_width i_1

288+ w_1 = imageWidth i_1

289− h_0 = image_height i_0

289+ h_0 = imageHeight i_0

290− h_1 = image_height i_1

290+ h_1 = imageHeight i_1

291 h = h_0 + h_1

292−vert_join _ _ = error "vert_join applied to undefined values."

292+vertJoin _ _ = error "vertJoin applied to undefined values."

293

src/Graphics/Vty/Inline.hs+43−44

@@ -10,18 +10,18 @@

10--

11-- @

12-- putStr \"Not styled. \"

13−-- put_attr_change_ $ do

13+-- putAttrChange_ $ do

14−-- back_color red

14+-- backColor red

15−-- apply_style underline

15+-- applyStyle underline

16-- putStr \" Styled! \"

17−-- put_attr_change_ $ default_all

17+-- putAttrChange_ $ defaultAll

18-- putStrLn \"Not styled.\"

19-- @

20--

21−-- 'put_attr_change' outputs the control codes to the terminal device 'Handle'. This is a duplicate

21+-- 'putAttrChange' outputs the control codes to the terminal device 'Handle'. This is a duplicate

22−-- of the 'stdout' handle when the 'terminal_handle' was (first) acquired. If 'stdout' has since been

22+-- of the 'stdout' handle when the 'terminalHandle' was (first) acquired. If 'stdout' has since been

23-- changed then 'putStr', 'putStrLn', 'print' etc.. will output to a different 'Handle' than

24−-- 'put_attr_change'

24+-- 'putAttrChange'

25--

27{-# LANGUAGE BangPatterns #-}

@@ -49,63 +49,62 @@ import System.IO

49type InlineM v = State Attr v

51-- | Set the background color to the provided 'Color'

52−back_color :: Color -> InlineM ()

52+backColor :: Color -> InlineM ()

53−back_color c = modify $ flip mappend ( current_attr `with_back_color` c )

53+backColor c = modify $ flip mappend ( currentAttr `withBackColor` c )

55-- | Set the foreground color to the provided 'Color'

56−fore_color :: Color -> InlineM ()

56+foreColor :: Color -> InlineM ()

57−fore_color c = modify $ flip mappend ( current_attr `with_fore_color` c )

57+foreColor c = modify $ flip mappend ( currentAttr `withForeColor` c )

59-- | Attempt to change the 'Style' of the following text.

60--

61-- If the terminal does not support the style change no error is produced. The style can still be

62-- removed.

63−apply_style :: Style -> InlineM ()

63+applyStyle :: Style -> InlineM ()

64−apply_style s = modify $ flip mappend ( current_attr `with_style` s )

64+applyStyle s = modify $ flip mappend ( currentAttr `withStyle` s )

66-- | Attempt to remove the specified 'Style' from the display of the following text.

67--

68−-- This will fail if apply_style for the given style has not been previously called.

68+-- This will fail if applyStyle for the given style has not been previously called.

69−remove_style :: Style -> InlineM ()

69+removeStyle :: Style -> InlineM ()

70−remove_style s_mask = modify $ \attr ->

70+removeStyle sMask = modify $ \attr ->

71− let style' = case attr_style attr of

71+ let style' = case attrStyle attr of

72− Default -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used."

72+ Default -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."

73− KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot remove_style if apply_style never used."

73+ KeepCurrent -> error $ "Graphics.Vty.Inline: Cannot removeStyle if applyStyle never used."

74− SetTo s -> s .&. complement s_mask

74+ SetTo s -> s .&. complement sMask

75− in attr { attr_style = SetTo style' }

75+ in attr { attrStyle = SetTo style' }

77-- | Reset the display attributes

78−default_all :: InlineM ()

78+defaultAll :: InlineM ()

79−default_all = put def_attr

79+defaultAll = put defAttr

81−-- | Apply the provided display attribute changes to the given terminal.

81+-- | Apply the provided display attribute changes to the given terminal output device.

82--

83-- This does not flush the terminal.

84−put_attr_change :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m ()

84+putAttrChange :: ( Applicative m, MonadIO m ) => Output -> InlineM () -> m ()

85−put_attr_change out c = liftIO $ do

85+putAttrChange out c = liftIO $ do

86− bounds <- display_bounds out

86+ bounds <- displayBounds out

87− dc <- display_context out bounds

87+ dc <- displayContext out bounds

88− mfattr <- prev_fattr <$> readIORef (assumed_state_ref out)

88+ mfattr <- prevFattr <$> readIORef (assumedStateRef out)

89 fattr <- case mfattr of

90 Nothing -> do

91− liftIO $ output_byte_buffer out $ writeToByteString $ write_default_attr dc

91+ liftIO $ outputByteBuffer out $ writeToByteString $ writeDefaultAttr dc

92− return $ FixedAttr default_style_mask Nothing Nothing

92+ return $ FixedAttr defaultStyleMask Nothing Nothing

93 Just v -> return v

94− let attr = execState c current_attr

94+ let attr = execState c currentAttr

95− attr' = limit_attr_for_display out attr

95+ attr' = limitAttrForDisplay out attr

96− fattr' = fix_display_attr fattr attr'

96+ fattr' = fixDisplayAttr fattr attr'

97− diffs = display_attr_diffs fattr fattr'

97+ diffs = displayAttrDiffs fattr fattr'

98− output_byte_buffer out $ writeToByteString $ write_set_attr dc fattr attr' diffs

98+ outputByteBuffer out $ writeToByteString $ writeSetAttr dc fattr attr' diffs

99− modifyIORef (assumed_state_ref out) $ \s -> s { prev_fattr = Just fattr' }

99+ modifyIORef (assumedStateRef out) $ \s -> s { prevFattr = Just fattr' }

100− inline_hack dc

100+ inlineHack dc

101

102−-- | Apply the provided display attributes changes to the terminal that was current at the time this

102+-- | Apply the provided display attributes changes to the terminal output device that was current at

103−-- was first used. Which, for most use cases, is the current terminal.

103+-- the time this was first used. Which, for most use cases, is the current terminal.

104--

105-- This will flush the terminal output.

106−put_attr_change_ :: ( Applicative m, MonadIO m ) => InlineM () -> m ()

106+putAttrChange_ :: ( Applicative m, MonadIO m ) => InlineM () -> m ()

107−put_attr_change_ c = liftIO $ do

107+putAttrChange_ c = liftIO $ withOutput $ \out -> do

108− out <- withVty $ return . output_iface

109 hFlush stdout

108 hFlush stdout

110− put_attr_change out c

109+ putAttrChange out c

111 hFlush stdout

110 hFlush stdout

src/Graphics/Vty/Inline/Unsafe.hs+21−7

@@ -7,20 +7,34 @@ import Data.IORef

8import System.IO.Unsafe

10−global_vty :: IORef (Maybe Vty)

10+globalVty :: IORef (Maybe Vty)

11−{-# NOINLINE global_vty #-}

11+{-# NOINLINE globalVty #-}

12+globalVty = unsafePerformIO $ newIORef Nothing

13+

14+globalOutput :: IORef (Maybe Output)

15+{-# NOINLINE globalOutput #-}

12−global_vty = unsafePerformIO $ newIORef Nothing

16+globalOutput = unsafePerformIO $ newIORef Nothing

14-- | This will create a Vty instance using 'mkVty' and execute an IO action provided that instance.

18-- | This will create a Vty instance using 'mkVty' and execute an IO action provided that instance.

15−-- The created Vty instance will be stored to the unsafe 'IORef' 'global_vty'.

19+-- The created Vty instance will be stored to the unsafe 'IORef' 'globalVty'.

16withVty :: (Vty -> IO b) -> IO b

20withVty :: (Vty -> IO b) -> IO b

17withVty f = do

21withVty f = do

18− mvty <- readIORef global_vty

22+ mvty <- readIORef globalVty

19 vty <- case mvty of

23 vty <- case mvty of

20 Nothing -> do

24 Nothing -> do

21− vty <- mkVty def

25+ vty <- mkVty $ def

22− writeIORef global_vty (Just vty)

26+ writeIORef globalVty (Just vty)

23 return vty

27 return vty

24 Just vty -> return vty

28 Just vty -> return vty

25 f vty

29 f vty

31+withOutput :: (Output -> IO b) -> IO b

32+withOutput f = do

33+ mout <- readIORef globalOutput

34+ out <- case mout of

35+ Nothing -> do

36+ out <- outputForCurrentTerminal

37+ writeIORef globalOutput (Just out)

38+ return out

39+ Just out -> return out

40+ f out

src/Graphics/Vty/Input.hs+19−19

@@ -39,8 +39,8 @@ module Graphics.Vty.Input ( Key(..)

39 , Event(..)

40 , Input(..)

41 , Config(..)

42− , input_for_current_terminal

42+ , inputForCurrentTerminal

43− , input_for_name_and_io

43+ , inputForNameAndIO

44 )

45 where

@@ -58,11 +58,11 @@ import System.Posix.IO (stdInput)

58import System.Posix.Types (Fd)

60-- | Set up the current terminal for input.

61−-- This determines the current terminal then invokes 'input_for_name_and_io'

61+-- This determines the current terminal then invokes 'inputForNameAndIO'

62−input_for_current_terminal :: Config -> IO Input

62+inputForCurrentTerminal :: Config -> IO Input

63−input_for_current_terminal config = do

63+inputForCurrentTerminal config = do

64− term_name <- getEnv "TERM"

64+ termName <- getEnv "TERM"

65− input_for_name_and_io config term_name stdInput

65+ inputForNameAndIO config termName stdInput

67-- | Set up the terminal attached to the given Fd for input. Returns a 'Input'.

68--

@@ -89,23 +89,23 @@ input_for_current_terminal config = do

89-- * IEXTEN disabled

90-- - extended functions are disabled. Uh. Whatever these are.

91--

92−input_for_name_and_io :: Config -> String -> Fd -> IO Input

92+inputForNameAndIO :: Config -> String -> Fd -> IO Input

93−input_for_name_and_io config term_name term_fd = do

93+inputForNameAndIO config termName termFd = do

94− terminal <- Terminfo.setupTerm term_name

94+ terminal <- Terminfo.setupTerm termName

95− let classify_table = classify_table_for_term term_name terminal

95+ let classifyTable = classifyTableForTerm termName terminal

96− (set_attrs,unset_attrs) <- attributeControl term_fd

96+ (setAttrs,unsetAttrs) <- attributeControl termFd

97− set_attrs

97+ setAttrs

98− input <- initInputForFd config classify_table term_fd

98+ input <- initInputForFd config classifyTable termFd

99 let pokeIO = Catch $ do

100 let e = error "(getsize in input layer)"

101− set_attrs

101+ setAttrs

102− writeChan (input^.event_channel) (EvResize e e)

102+ writeChan (input^.eventChannel) (EvResize e e)

103 _ <- installHandler windowChange pokeIO Nothing

104 _ <- installHandler continueProcess pokeIO Nothing

105 return $ input

106− { shutdown_input = do

106+ { shutdownInput = do

107− shutdown_input input

107+ shutdownInput input

108 _ <- installHandler windowChange Ignore Nothing

109 _ <- installHandler continueProcess Ignore Nothing

110− unset_attrs

110+ unsetAttrs

111 }

src/Graphics/Vty/Input/Internal.hs+72−72

@@ -45,14 +45,14 @@ instance Default Config where

45data Input = Input

46 { -- | Channel of events direct from input processing. Unlike 'next_event' this will not refresh

47 -- the display if the next event is an 'EvResize'.

48− _event_channel :: Chan Event

48+ _eventChannel :: Chan Event

49 -- | Shuts down the input processing. This should return the terminal input state to before

50 -- the input initialized.

51− , shutdown_input :: IO ()

51+ , shutdownInput :: IO ()

52 -- | Changes to this value are reflected after the next event.

53− , _config_ref :: IORef Config

53+ , _configRef :: IORef Config

54 -- | File descriptor used for input.

55− , _input_fd :: Fd

55+ , _inputFd :: Fd

56 }

58makeLenses ''Input

@@ -71,10 +71,10 @@ data InputBuffer = InputBuffer

71makeLenses ''InputBuffer

73data InputState = InputState

74− { _unprocessed_bytes :: String

74+ { _unprocessedBytes :: String

75− , _applied_config :: Config

75+ , _appliedConfig :: Config

76− , _input_buffer :: InputBuffer

76+ , _inputBuffer :: InputBuffer

77− , _stop_request_ref :: IORef Bool

77+ , _stopRequestRef :: IORef Bool

78 , _classifier :: String -> KClass

79 }

@@ -84,63 +84,63 @@ type InputM a = StateT InputState (ReaderT Input IO) a

85-- this must be run on an OS thread dedicated to this input handling.

86-- otherwise the terminal timing read behavior will block the execution of the lightweight threads.

87−loop_input_processor :: InputM ()

87+loopInputProcessor :: InputM ()

88−loop_input_processor = do

88+loopInputProcessor = do

89− read_from_device >>= add_bytes_to_process

89+ readFromDevice >>= addBytesToProcess

90− valid_events <- many parse_event

90+ validEvents <- many parseEvent

91− forM_ valid_events emit

91+ forM_ validEvents emit

92− drop_invalid

92+ dropInvalid

93− stop_if_requested <|> loop_input_processor

93+ stopIfRequested <|> loopInputProcessor

95−add_bytes_to_process :: String -> InputM ()

95+addBytesToProcess :: String -> InputM ()

96−add_bytes_to_process block = unprocessed_bytes <>= block

96+addBytesToProcess block = unprocessedBytes <>= block

98emit :: Event -> InputM ()

99−emit event = view event_channel >>= liftIO . flip writeChan event

99+emit event = view eventChannel >>= liftIO . flip writeChan event

100

101-- There should be two versions of this method:

102-- 1. using VMIN and VTIME when under the threaded runtime

103-- 2. emulating VMIN and VTIME in userspace when under the non-threaded runtime.

104−read_from_device :: InputM String

104+readFromDevice :: InputM String

105−read_from_device = do

105+readFromDevice = do

106− new_config <- view config_ref >>= liftIO . readIORef

106+ newConfig <- view configRef >>= liftIO . readIORef

107− old_config <- use applied_config

107+ oldConfig <- use appliedConfig

108− fd <- view input_fd

108+ fd <- view inputFd

109− when (new_config /= old_config) $ do

109+ when (newConfig /= oldConfig) $ do

110− liftIO $ apply_timing_config fd new_config

110+ liftIO $ applyTimingConfig fd newConfig

111− applied_config .= new_config

111+ appliedConfig .= newConfig

112− buffer_ptr <- use $ input_buffer.ptr

112+ bufferPtr <- use $ inputBuffer.ptr

113− max_bytes <- use $ input_buffer.size

113+ maxBytes <- use $ inputBuffer.size

114 liftIO $ do

115− bytes_read <- fdReadBuf fd buffer_ptr (fromIntegral max_bytes)

115+ bytes_read <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)

116 if bytes_read > 0

117− then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytes_read) buffer_ptr

117+ then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytes_read) bufferPtr

118 else return []

119

120−apply_timing_config :: Fd -> Config -> IO ()

120+applyTimingConfig :: Fd -> Config -> IO ()

121−apply_timing_config fd config =

121+applyTimingConfig fd config =

122 let vtime = min 255 $ singleEscPeriod config `div` 100000

123− in set_term_timing fd 1 vtime

123+ in setTermTiming fd 1 vtime

124

125−parse_event :: InputM Event

125+parseEvent :: InputM Event

126−parse_event = do

126+parseEvent = do

127 c <- use classifier

128− b <- use unprocessed_bytes

128+ b <- use unprocessedBytes

129 case c b of

130 Valid e remaining -> do

131− unprocessed_bytes .= remaining

131+ unprocessedBytes .= remaining

132 return e

133 _ -> mzero

134

135−drop_invalid :: InputM ()

135+dropInvalid :: InputM ()

136−drop_invalid = do

136+dropInvalid = do

137 c <- use classifier

138− b <- use unprocessed_bytes

138+ b <- use unprocessedBytes

139− when (c b == Invalid) $ unprocessed_bytes .= []

139+ when (c b == Invalid) $ unprocessedBytes .= []

140

141−stop_if_requested :: InputM ()

141+stopIfRequested :: InputM ()

142−stop_if_requested = do

142+stopIfRequested = do

143− True <- (liftIO . readIORef) =<< use stop_request_ref

143+ True <- (liftIO . readIORef) =<< use stopRequestRef

144 return ()

145

146-- This makes a kind of tri. Has space efficiency issues with large input blocks.

@@ -151,25 +151,25 @@ stop_if_requested = do

151compile :: ClassifyTable -> [Char] -> KClass

152compile table = cl' where

153 -- take all prefixes and create a set of these

154− prefix_set = S.fromList $ concatMap (init . inits . fst) $ table

154+ prefixSet = S.fromList $ concatMap (init . inits . fst) $ table

155− event_for_input = M.fromList table

155+ eventForInput = M.fromList table

156 cl' [] = Prefix

157− cl' input_block = case M.lookup input_block event_for_input of

157+ cl' inputBlock = case M.lookup inputBlock eventForInput of

158 Just e -> Valid e []

159− Nothing -> case S.member input_block prefix_set of

159+ Nothing -> case S.member inputBlock prefixSet of

160 True -> Prefix

161− -- if the input_block is exactly what is expected for an event then consume the whole

161+ -- if the inputBlock is exactly what is expected for an event then consume the whole

162 -- block and return the event

163 -- look up progressively smaller tails of the input block until an event is found

164 -- The assumption is that the event that consumes the most input bytes should be

165 -- produced.

166 -- The test verify_full_syn_input_to_event_2x verifies this.

167− -- H: There will always be one match. The prefix_set contains, by definition, all

167+ -- H: There will always be one match. The prefixSet contains, by definition, all

168 -- prefixes of an event.

169 False ->

170− let input_tails = init $ tail $ tails input_block

170+ let inputTails = init $ tail $ tails inputBlock

171− in case mapMaybe (\s -> (,) s `fmap` M.lookup s event_for_input) input_tails of

171+ in case mapMaybe (\s -> (,) s `fmap` M.lookup s eventForInput) inputTails of

172− (s,e) : _ -> Valid e (drop (length s) input_block)

172+ (s,e) : _ -> Valid e (drop (length s) inputBlock)

173 -- neither a prefix or a full event. Might be interesting to log.

174 [] -> Invalid

175

@@ -198,15 +198,15 @@ utf8Length c

198 | c < 0xF0 = 3

199 | otherwise = 4

200

201−run_input_processor_loop :: ClassifyTable -> Input -> IORef Bool -> IO ()

201+runInputProcessorLoop :: ClassifyTable -> Input -> IORef Bool -> IO ()

202−run_input_processor_loop classify_table input stop_flag = do

202+runInputProcessorLoop classifyTable input stopFlag = do

203− let buffer_size = 1024

203+ let bufferSize = 1024

204− allocaArray buffer_size $ \(buffer_ptr :: Ptr Word8) -> do

204+ allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do

205− s0 <- InputState [] <$> readIORef (_config_ref input)

205+ s0 <- InputState [] <$> readIORef (_configRef input)

206− <*> pure (InputBuffer buffer_ptr buffer_size)

206+ <*> pure (InputBuffer bufferPtr bufferSize)

207− <*> pure stop_flag

207+ <*> pure stopFlag

208− <*> pure (classify classify_table)

208+ <*> pure (classify classifyTable)

209− runReaderT (evalStateT loop_input_processor s0) input

209+ runReaderT (evalStateT loopInputProcessor s0) input

210

211attributeControl :: Fd -> IO (IO (), IO ())

212attributeControl fd = do

@@ -214,21 +214,21 @@ attributeControl fd = do

214 let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts

215 , EnableEcho, ProcessInput, ExtendedFunctions

216 ]

217− let set_attrs = setTerminalAttributes fd vtyMode Immediately

217+ let setAttrs = setTerminalAttributes fd vtyMode Immediately

218− unset_attrs = setTerminalAttributes fd original Immediately

218+ unsetAttrs = setTerminalAttributes fd original Immediately

219− return (set_attrs,unset_attrs)

219+ return (setAttrs,unsetAttrs)

220

221-- This is an example of an algorithm where code coverage could be high, even 100%, but the

222-- algorithm still under tested. I should collect more of these examples...

223initInputForFd :: Config -> ClassifyTable -> Fd -> IO Input

224−initInputForFd config classify_table in_fd = do

224+initInputForFd config classifyTable inFd = do

225− apply_timing_config in_fd config

225+ applyTimingConfig inFd config

226− stop_flag <- newIORef False

226+ stopFlag <- newIORef False

227 input <- Input <$> newChan

228− <*> pure (writeIORef stop_flag True)

228+ <*> pure (writeIORef stopFlag True)

229 <*> newIORef config

230− <*> pure in_fd

230+ <*> pure inFd

231− _ <- forkOS $ run_input_processor_loop classify_table input stop_flag

231+ _ <- forkOS $ runInputProcessorLoop classifyTable input stopFlag

232 return input

233

234−foreign import ccall "vty_set_term_timing" set_term_timing :: Fd -> Int -> Int -> IO ()

234+foreign import ccall "vty_set_term_timing" setTermTiming :: Fd -> Int -> Int -> IO ()

src/Graphics/Vty/Input/Terminfo.hs+29−29

@@ -34,25 +34,25 @@ import System.Console.Terminfo

34--

35-- \todo terminfo meta is not supported.

36-- \todo no 8bit

37−classify_table_for_term :: String -> Terminal -> ClassifyTable

37+classifyTableForTerm :: String -> Terminal -> ClassifyTable

38−classify_table_for_term term_name term =

38+classifyTableForTerm termName term =

39− concat $ caps_classify_table term keys_from_caps_table

39+ concat $ capsClassifyTable term keysFromCapsTable

40− : universal_table

40+ : universalTable

41− : term_specific_tables term_name

41+ : termSpecificTables termName

43-- | key table assumed to be applicable to all terminals.

44−universal_table :: ClassifyTable

44+universalTable :: ClassifyTable

45−universal_table = concat [visible_chars, ctrl_chars, ctrl_meta_chars, special_support_keys]

45+universalTable = concat [visibleChars, ctrlChars, ctrlMetaChars, specialSupportKeys]

47−caps_classify_table :: Terminal -> [(String,Event)] -> ClassifyTable

47+capsClassifyTable :: Terminal -> [(String,Event)] -> ClassifyTable

48−caps_classify_table terminal table = [(x,y) | (Just x,y) <- map extract_cap table]

48+capsClassifyTable terminal table = [(x,y) | (Just x,y) <- map extractCap table]

49− where extract_cap = first (getCapability terminal . tiGetStr)

49+ where extractCap = first (getCapability terminal . tiGetStr)

51-- | tables specific to a given terminal that are not derivable from terminfo.

52−term_specific_tables :: String -> [ClassifyTable]

52+termSpecificTables :: String -> [ClassifyTable]

53−term_specific_tables term_name

53+termSpecificTables termName

54− | ANSI.supports term_name = ANSI.tables

54+ | ANSI.supports termName = ANSI.tables

55− | XTerm7Bit.supports term_name = XTerm7Bit.tables

55+ | XTerm7Bit.supports termName = XTerm7Bit.tables

56 | otherwise = []

58-- | Visible characters in the ISO-8859-1 and UTF-8 common set.

@@ -62,16 +62,16 @@ term_specific_tables term_name

62--

63-- TODO: resolve

64-- 1. start at ' '. The earlier characters are all ctrl_char_keys

65−visible_chars :: ClassifyTable

65+visibleChars :: ClassifyTable

66−visible_chars = [ ([x], EvKey (KChar x) [])

66+visibleChars = [ ([x], EvKey (KChar x) [])

67− | x <- [' ' .. toEnum 0xC1]

67+ | x <- [' ' .. toEnum 0xC1]

68− ]

68+ ]

70-- | Non visible characters in the ISO-8859-1 and UTF-8 common set translated to ctrl + char.

71--

72-- \todo resolve CTRL-i is the same as tab

73−ctrl_chars :: ClassifyTable

73+ctrlChars :: ClassifyTable

74−ctrl_chars =

74+ctrlChars =

75 [ ([toEnum x],EvKey (KChar y) [MCtrl])

76 | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_']),

77 y /= 'i', -- Resolve issue #3 where CTRL-i hides TAB.

@@ -79,12 +79,12 @@ ctrl_chars =

79 ]

81-- | Ctrl+Meta+Char

82−ctrl_meta_chars :: ClassifyTable

82+ctrlMetaChars :: ClassifyTable

83−ctrl_meta_chars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrl_chars

83+ctrlMetaChars = map (\(s,EvKey c m) -> ('\ESC':s, EvKey c (MMeta:m))) ctrlChars

85-- | esc, meta esc, delete, meta delete, enter, meta enter

86−special_support_keys :: ClassifyTable

86+specialSupportKeys :: ClassifyTable

87−special_support_keys =

87+specialSupportKeys =

88 [ -- special support for ESC

89 ("\ESC",EvKey KEsc []), ("\ESC\ESC",EvKey KEsc [MMeta])

90 -- Special support for backspace

@@ -150,8 +150,8 @@ special_support_keys =

150-- * kRIT - shift right

151--

152-- * kcuu1 - up

153−keys_from_caps_table :: ClassifyTable

153+keysFromCapsTable :: ClassifyTable

154−keys_from_caps_table =

154+keysFromCapsTable =

155 [ ("ka1", EvKey KUpLeft [])

156 , ("ka3", EvKey KUpRight [])

157 , ("kb2", EvKey KCenter [])

@@ -177,8 +177,8 @@ keys_from_caps_table =

177 , ("kLFT", EvKey KLeft [MShift])

178 , ("kRIT", EvKey KRight [MShift])

179 , ("kcuu1", EvKey KUp [])

180− ] ++ function_key_caps_table

180+ ] ++ functionKeyCapsTable

181

182-- | cap names for function keys

183−function_key_caps_table :: ClassifyTable

183+functionKeyCapsTable :: ClassifyTable

184−function_key_caps_table = flip map [0..63] $ \n -> ("kf" ++ show n, EvKey (KFun n) [])

184+functionKeyCapsTable = flip map [0..63] $ \n -> ("kf" ++ show n, EvKey (KFun n) [])

src/Graphics/Vty/Input/Terminfo/ANSI.hs+18−18

@@ -8,8 +8,8 @@ supports "ansi" = True

8supports _ = False

10-- | Encoding for navigation keys.

11−nav_keys_0 :: ClassifyTable

11+navKeys0 :: ClassifyTable

12−nav_keys_0 =

12+navKeys0 =

13 [ k "G" KCenter

14 , k "P" KPause

15 , k "A" KUp

@@ -23,8 +23,8 @@ nav_keys_0 =

23 where k c s = ("\ESC["++c, EvKey s [])

25-- | VT 100 (?) encoding for shift, meta and ctrl plus arrows/home/end

26−nav_keys_1 :: ClassifyTable

26+navKeys1 :: ClassifyTable

27−nav_keys_1 =

27+navKeys1 =

28 [("\ESC[" ++ charCnt ++ show mc++c,EvKey s m)

29 | charCnt <- ["1;", ""], -- we can have a count or not

30 (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3),

@@ -34,15 +34,15 @@ nav_keys_1 =

34 ]

36-- | VT 100 (?) encoding for ins, del, pageup, pagedown, home, end

37−nav_keys_2 :: ClassifyTable

37+navKeys2 :: ClassifyTable

38−nav_keys_2 =

38+navKeys2 =

39 let k n s = ("\ESC["++show n++"~",EvKey s [])

40 in zipWith k [2::Int,3,5,6,1,4]

41 [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]

43-- | VT 100 (?) encoding for ctrl + ins, del, pageup, pagedown, home, end

44−nav_keys_3 :: ClassifyTable

44+navKeys3 :: ClassifyTable

45−nav_keys_3 =

45+navKeys3 =

46 let k n s = ("\ESC["++show n++";5~", EvKey s [MCtrl])

47 in zipWith k [2::Int,3,5,6,1,4]

48 [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]

@@ -56,8 +56,8 @@ nav_keys_3 =

56-- ``meta mode'' on and off, they can be given as smm and rmm."

57--

58-- That is more complex than below. I cannot fault the original author for just hard coding a table.

59−function_keys_1 :: ClassifyTable

59+functionKeys1 :: ClassifyTable

60−function_keys_1 =

60+functionKeys1 =

61 let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-(nrs!!0)+ff) m) | n <- nrs ] in

62 concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ]

@@ -70,19 +70,19 @@ function_keys_1 =

70-- the same as ESC should examine km and current encoding.

71-- 3. stopped enumeration at '~' instead of '\DEL'. The latter is mapped to KBS by

72-- special_support_keys.

73−function_keys_2 :: ClassifyTable

73+functionKeys2 :: ClassifyTable

74−function_keys_2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta])

74+functionKeys2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta])

75 | x <- '\t':[' ' .. '~']

76 , x /= '['

77 ]

79tables :: [ClassifyTable]

80tables =

81− [ nav_keys_0

81+ [ navKeys0

82− , nav_keys_1

82+ , navKeys1

83− , nav_keys_2

83+ , navKeys2

84− , nav_keys_3

84+ , navKeys3

85− , function_keys_1

85+ , functionKeys1

86− , function_keys_2

86+ , functionKeys2

87 ]

src/Graphics/Vty/Input/Terminfo/XTerm7Bit.hs+18−18

@@ -12,8 +12,8 @@ supports term_name = "xterm" `isPrefixOf` term_name && not ("8bit" `isInfixOf` t

12-- | Encoding for navigation keys.

13--

14-- TODO: This is not the same as the input bytes pulled from teh caps table.

15−nav_keys_0 :: ClassifyTable

15+navKeys0 :: ClassifyTable

16−nav_keys_0 =

16+navKeys0 =

17 [ k "G" KCenter

18 , k "P" KPause

19 , k "A" KUp

@@ -27,8 +27,8 @@ nav_keys_0 =

27 where k c s = ("\ESC["++c,EvKey s [])

29-- | VT 100 (?) encoding for shift, meta and ctrl plus arrows/home/end

30−nav_keys_1 :: ClassifyTable

30+navKeys1 :: ClassifyTable

31−nav_keys_1 =

31+navKeys1 =

32 [("\ESC[" ++ charCnt ++ show mc++c,EvKey s m)

33 | charCnt <- ["1;", ""], -- we can have a count or not

34 (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3),

@@ -37,15 +37,15 @@ nav_keys_1 =

37 ]

39-- | VT 100 (?) encoding for ins, del, pageup, pagedown, home, end

40−nav_keys_2 :: ClassifyTable

40+navKeys2 :: ClassifyTable

41−nav_keys_2 =

41+navKeys2 =

42 let k n s = ("\ESC["++show n++"~",EvKey s [])

43 in zipWith k [2::Int,3,5,6,1,4]

44 [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]

46-- | VT 100 (?) encoding for ctrl + ins, del, pageup, pagedown, home, end

47−nav_keys_3 :: ClassifyTable

47+navKeys3 :: ClassifyTable

48−nav_keys_3 =

48+navKeys3 =

49 let k n s = ("\ESC["++show n++";5~",EvKey s [MCtrl])

50 in zipWith k [2::Int,3,5,6,1,4]

51 [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]

@@ -59,8 +59,8 @@ nav_keys_3 =

59-- ``meta mode'' on and off, they can be given as smm and rmm."

60--

61-- That is more complex than below. I cannot fault the original author for just hard coding a table.

62−function_keys_1 :: ClassifyTable

62+functionKeys1 :: ClassifyTable

63−function_keys_1 =

63+functionKeys1 =

64 let f ff nrs m = [ ("\ESC["++show n++"~",EvKey (KFun $ n-(nrs!!0)+ff) m) | n <- nrs ] in

65 concat [f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ]

@@ -73,8 +73,8 @@ function_keys_1 =

73-- the same as ESC should examine km and current encoding.

74-- 3. stopped enumeration at '~' instead of '\DEL'. The latter is mapped to KBS by

75-- special_support_keys.

76−function_keys_2 :: ClassifyTable

76+functionKeys2 :: ClassifyTable

77−function_keys_2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta])

77+functionKeys2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta])

78 | x <- '\t':[' ' .. '~']

79 , x /= '['

80 ]

@@ -82,11 +82,11 @@ function_keys_2 = [ ('\ESC':[x],EvKey (KChar x) [MMeta])

82-- | classify table for ANSI terminals

83tables :: [ClassifyTable]

84tables =

85− [ nav_keys_0

85+ [ navKeys0

86− , nav_keys_1

86+ , navKeys1

87− , nav_keys_2

87+ , navKeys2

88− , nav_keys_3

88+ , navKeys3

89− , function_keys_1

89+ , functionKeys1

90− , function_keys_2

90+ , functionKeys2

91 ]

src/Graphics/Vty/Output.hs+37−37

@@ -20,8 +20,8 @@ module Graphics.Vty.Output ( module Graphics.Vty.Output

20 , Output(..) -- \todo hide constructors

21 , AssumedState(..)

22 , DisplayContext(..) -- \todo hide constructors

23− , output_picture

23+ , outputPicture

24− , display_context

24+ , displayContext

25 )

26 where

@@ -74,35 +74,35 @@ import System.IO

74--

75-- \todo add an implementation for windows that does not depend on terminfo. Should be installable

76-- with only what is provided in the haskell platform. Use ansi-terminal

77−output_for_current_terminal :: ( Applicative m, MonadIO m ) => m Output

77+outputForCurrentTerminal :: ( Applicative m, MonadIO m ) => m Output

78−output_for_current_terminal = do

78+outputForCurrentTerminal = do

79− term_type <- liftIO $ getEnv "TERM"

79+ termType <- liftIO $ getEnv "TERM"

80− out_handle <- liftIO $ hDuplicate stdout

80+ outHandle <- liftIO $ hDuplicate stdout

81− output_for_name_and_io term_type out_handle

81+ outputForNameAndIO termType outHandle

83-- | gives an output method structure for a terminal with the given name and the given 'Handle'.

84−output_for_name_and_io :: (Applicative m, MonadIO m) => String -> Handle -> m Output

84+outputForNameAndIO :: (Applicative m, MonadIO m) => String -> Handle -> m Output

85−output_for_name_and_io term_type out_handle = do

85+outputForNameAndIO termType outHandle = do

86− t <- if "xterm" `isPrefixOf` term_type

86+ t <- if "xterm" `isPrefixOf` termType

87 then do

88− maybe_terminal_app <- get_env "TERM_PROGRAM"

88+ maybeTerminalApp <- mGetEnv "TERM_PROGRAM"

89− case maybe_terminal_app of

89+ case maybeTerminalApp of

90 Nothing

91− -> XTermColor.reserve_terminal term_type out_handle

91+ -> XTermColor.reserveTerminal termType outHandle

92 Just v | v == "Apple_Terminal" || v == "iTerm.app"

93 -> do

94− maybe_xterm <- get_env "XTERM_VERSION"

94+ maybeXterm <- mGetEnv "XTERM_VERSION"

95− case maybe_xterm of

95+ case maybeXterm of

96− Nothing -> MacOSX.reserve_terminal v out_handle

96+ Nothing -> MacOSX.reserveTerminal v outHandle

97− Just _ -> XTermColor.reserve_terminal term_type out_handle

97+ Just _ -> XTermColor.reserveTerminal termType outHandle

98 -- Assume any other terminal that sets TERM_PROGRAM to not be an OS X terminal.app

99 -- like terminal?

100− _ -> XTermColor.reserve_terminal term_type out_handle

100+ _ -> XTermColor.reserveTerminal termType outHandle

101 -- Not an xterm-like terminal. try for generic terminfo.

102− else TerminfoBased.reserve_terminal term_type out_handle

102+ else TerminfoBased.reserveTerminal termType outHandle

103 return t

104 where

105− get_env var = do

105+ mGetEnv var = do

106 mv <- liftIO $ try $ getEnv var

107 case mv of

108 Left (_e :: SomeException) -> return $ Nothing

@@ -114,25 +114,25 @@ output_for_name_and_io term_type out_handle = do

114-- Characters can be a variable number of columns in width.

115--

116-- Currently, the only way to set the cursor position to a given character coordinate is to specify

117−-- the coordinate in the Picture instance provided to output_picture or refresh.

117+-- the coordinate in the Picture instance provided to outputPicture or refresh.

118−set_cursor_pos :: MonadIO m => Output -> Int -> Int -> m ()

118+setCursorPos :: MonadIO m => Output -> Int -> Int -> m ()

119−set_cursor_pos t x y = do

119+setCursorPos t x y = do

120− bounds <- display_bounds t

120+ bounds <- displayBounds t

121− when (x >= 0 && x < region_width bounds && y >= 0 && y < region_height bounds) $ do

121+ when (x >= 0 && x < regionWidth bounds && y >= 0 && y < regionHeight bounds) $ do

122− dc <- display_context t bounds

122+ dc <- displayContext t bounds

123− liftIO $ output_byte_buffer t $ writeToByteString $ write_move_cursor dc x y

123+ liftIO $ outputByteBuffer t $ writeToByteString $ writeMoveCursor dc x y

124

125-- | Hides the cursor

126−hide_cursor :: MonadIO m => Output -> m ()

126+hideCursor :: MonadIO m => Output -> m ()

127−hide_cursor t = do

127+hideCursor t = do

128− bounds <- display_bounds t

128+ bounds <- displayBounds t

129− dc <- display_context t bounds

129+ dc <- displayContext t bounds

130− liftIO $ output_byte_buffer t $ writeToByteString $ write_hide_cursor dc

130+ liftIO $ outputByteBuffer t $ writeToByteString $ writeHideCursor dc

131

132-- | Shows the cursor

133−show_cursor :: MonadIO m => Output -> m ()

133+showCursor :: MonadIO m => Output -> m ()

134−show_cursor t = do

134+showCursor t = do

135− bounds <- display_bounds t

135+ bounds <- displayBounds t

136− dc <- display_context t bounds

136+ dc <- displayContext t bounds

137− liftIO $ output_byte_buffer t $ writeToByteString $ write_show_cursor dc

137+ liftIO $ outputByteBuffer t $ writeToByteString $ writeShowCursor dc

138

src/Graphics/Vty/Output/Interface.hs+112−112

@@ -30,8 +30,8 @@ import qualified Data.Vector as Vector

31data Output = Output

32 { -- | Text identifier for the output device. Used for debugging.

33− terminal_ID :: String

33+ terminalID :: String

34− , release_terminal :: MonadIO m => m ()

34+ , releaseTerminal :: MonadIO m => m ()

35 -- | Clear the display and initialize the terminal to some initial display state.

36 --

37 -- The expectation of a program is that the display starts in some initial state.

@@ -46,45 +46,45 @@ data Output = Output

46 --

47 -- - The previous state cannot be determined

48 -- - When exclusive access to a display is released the display returns to the previous state.

49− , reserve_display :: MonadIO m => m ()

49+ , reserveDisplay :: MonadIO m => m ()

50− -- | Return the display to the state before reserve_display

50+ -- | Return the display to the state before `reserveDisplay`

51 -- If no previous state then set the display state to the initial state.

52− , release_display :: MonadIO m => m ()

52+ , releaseDisplay :: MonadIO m => m ()

53 -- | Returns the current display bounds.

54− , display_bounds :: MonadIO m => m DisplayRegion

54+ , displayBounds :: MonadIO m => m DisplayRegion

55 -- | Output the byte string to the terminal device.

56− , output_byte_buffer :: BS.ByteString -> IO ()

56+ , outputByteBuffer :: BS.ByteString -> IO ()

57 -- | Maximum number of colors supported by the context.

58− , context_color_count :: Int

58+ , contextColorCount :: Int

59 -- | if the cursor can be shown / hidden

60− , supports_cursor_visibility :: Bool

60+ , supportsCursorVisibility :: Bool

61− , assumed_state_ref :: IORef AssumedState

61+ , assumedStateRef :: IORef AssumedState

62 -- | Acquire display access to the given region of the display.

63 -- Currently all regions have the upper left corner of (0,0) and the lower right corner at

64 -- (max display_width provided_width, max display_height provided_height)

65− , mk_display_context :: MonadIO m => Output -> DisplayRegion -> m DisplayContext

65+ , mkDisplayContext :: MonadIO m => Output -> DisplayRegion -> m DisplayContext

66 }

68−display_context :: MonadIO m => Output -> DisplayRegion -> m DisplayContext

68+displayContext :: MonadIO m => Output -> DisplayRegion -> m DisplayContext

69−display_context t = liftIO . mk_display_context t t

69+displayContext t = liftIO . mkDisplayContext t t

71data AssumedState = AssumedState

72− { prev_fattr :: Maybe FixedAttr

72+ { prevFattr :: Maybe FixedAttr

73− , prev_output_ops :: Maybe DisplayOps

73+ , prevOutputOps :: Maybe DisplayOps

74 }

76−initial_assumed_state :: AssumedState

76+initialAssumedState :: AssumedState

77−initial_assumed_state = AssumedState Nothing Nothing

77+initialAssumedState = AssumedState Nothing Nothing

79data DisplayContext = DisplayContext

80− { context_device :: Output

80+ { contextDevice :: Output

81 -- | Provide the bounds of the display context.

82− , context_region :: DisplayRegion

82+ , contextRegion :: DisplayRegion

83 -- | sets the output position to the specified row and column. Where the number of bytes

84 -- required for the control codes can be specified seperate from the actual byte sequence.

85− , write_move_cursor :: Int -> Int -> Write

85+ , writeMoveCursor :: Int -> Int -> Write

86− , write_show_cursor :: Write

86+ , writeShowCursor :: Write

87− , write_hide_cursor :: Write

87+ , writeHideCursor :: Write

88 -- | Assure the specified output attributes will be applied to all the following text until the

89 -- next output attribute change. Where the number of bytes required for the control codes can

90 -- be specified seperate from the actual byte sequence. The required number of bytes must be

@@ -96,17 +96,17 @@ data DisplayContext = DisplayContext

96 -- attributes. In order to support this the currently applied display attributes are required.

97 -- In addition it may be possible to optimize the state changes based off the currently applied

98 -- display attributes.

99− , write_set_attr :: FixedAttr -> Attr -> DisplayAttrDiff -> Write

99+ , writeSetAttr :: FixedAttr -> Attr -> DisplayAttrDiff -> Write

100 -- | Reset the display attributes to the default display attributes

101− , write_default_attr :: Write

101+ , writeDefaultAttr :: Write

102− , write_row_end :: Write

102+ , writeRowEnd :: Write

103− -- | See Graphics.Vty.Output.XTermColor.inline_hack

103+ -- | See `Graphics.Vty.Output.XTermColor.inlineHack`

104− , inline_hack :: IO ()

104+ , inlineHack :: IO ()

105 }

106

107-- | All terminals serialize UTF8 text to the terminal device exactly as serialized in memory.

108−write_utf8_text :: BS.ByteString -> Write

108+writeUtf8Text :: BS.ByteString -> Write

109−write_utf8_text = writeByteString

109+writeUtf8Text = writeByteString

110

111-- | Displays the given `Picture`.

112--

@@ -122,135 +122,135 @@ write_utf8_text = writeByteString

122--

123-- todo: specify possible IO exceptions.

124-- abstract from IO monad to a MonadIO instance.

125−output_picture :: MonadIO m => DisplayContext -> Picture -> m ()

125+outputPicture :: MonadIO m => DisplayContext -> Picture -> m ()

126−output_picture dc pic = liftIO $ do

126+outputPicture dc pic = liftIO $ do

127− as <- readIORef (assumed_state_ref $ context_device dc)

127+ as <- readIORef (assumedStateRef $ contextDevice dc)

128− let manip_cursor = supports_cursor_visibility (context_device dc)

128+ let manipCursor = supportsCursorVisibility (contextDevice dc)

129− r = context_region dc

129+ r = contextRegion dc

130− ops = display_ops_for_pic pic r

130+ ops = displayOpsForPic pic r

131− initial_attr = FixedAttr default_style_mask Nothing Nothing

131+ initialAttr = FixedAttr defaultStyleMask Nothing Nothing

132 -- Diff the previous output against the requested output. Differences are currently on a per-row

133 -- basis.

134 -- \todo handle resizes that crop the dominate directions better.

135− diffs :: [Bool] = case prev_output_ops as of

135+ diffs :: [Bool] = case prevOutputOps as of

136− Nothing -> replicate (fromEnum $ region_height $ effected_region ops) True

136+ Nothing -> replicate (fromEnum $ regionHeight $ effectedRegion ops) True

137− Just previous_ops -> if effected_region previous_ops /= effected_region ops

137+ Just previousOps -> if effectedRegion previousOps /= effectedRegion ops

138− then replicate (display_ops_rows ops) True

138+ then replicate (displayOpsRows ops) True

139− else zipWith (/=) (Vector.toList previous_ops)

139+ else zipWith (/=) (Vector.toList previousOps)

140 (Vector.toList ops)

141 -- build the Write corresponding to the output image

142− out = (if manip_cursor then write_hide_cursor dc else mempty)

142+ out = (if manipCursor then writeHideCursor dc else mempty)

143− `mappend` write_default_attr dc

143+ `mappend` writeDefaultAttr dc

144− `mappend` write_output_ops dc initial_attr diffs ops

144+ `mappend` writeOutputOps dc initialAttr diffs ops

145 `mappend`

146− (case pic_cursor pic of

146+ (case picCursor pic of

147− _ | not manip_cursor -> mempty

147+ _ | not manipCursor -> mempty

148 NoCursor -> mempty

149 Cursor x y ->

150− let m = cursor_output_map ops $ pic_cursor pic

150+ let m = cursorOutputMap ops $ picCursor pic

151− (ox, oy) = char_to_output_pos m (x,y)

151+ (ox, oy) = charToOutputPos m (x,y)

152− in write_show_cursor dc `mappend` write_move_cursor dc ox oy

152+ in writeShowCursor dc `mappend` writeMoveCursor dc ox oy

153 )

154 -- ... then serialize

155− output_byte_buffer (context_device dc) (writeToByteString out)

155+ outputByteBuffer (contextDevice dc) (writeToByteString out)

156 -- Cache the output spans.

157− let as' = as { prev_output_ops = Just ops }

157+ let as' = as { prevOutputOps = Just ops }

158− writeIORef (assumed_state_ref $ context_device dc) as'

158+ writeIORef (assumedStateRef $ contextDevice dc) as'

159

160−write_output_ops :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write

160+writeOutputOps :: DisplayContext -> FixedAttr -> [Bool] -> DisplayOps -> Write

161−write_output_ops dc in_fattr diffs ops =

161+writeOutputOps dc inFattr diffs ops =

162− let (_, out, _, _) = Vector.foldl' write_output_ops'

162+ let (_, out, _, _) = Vector.foldl' writeOutputOps'

163− (0, mempty, in_fattr, diffs)

163+ (0, mempty, inFattr, diffs)

164− ops

164+ ops

165 in out

166 where

167− write_output_ops' (y, out, fattr, True : diffs') span_ops

167+ writeOutputOps' (y, out, fattr, True : diffs') spanOps

168− = let (span_out, fattr') = write_span_ops dc y fattr span_ops

168+ = let (spanOut, fattr') = writeSpanOps dc y fattr spanOps

169− in (y+1, out `mappend` span_out, fattr', diffs')

169+ in (y+1, out `mappend` spanOut, fattr', diffs')

170− write_output_ops' (y, out, fattr, False : diffs') _span_ops

170+ writeOutputOps' (y, out, fattr, False : diffs') _spanOps

171 = (y + 1, out, fattr, diffs')

172− write_output_ops' (_y, _out, _fattr, []) _span_ops

172+ writeOutputOps' (_y, _out, _fattr, []) _spanOps

173 = error "vty - output spans without a corresponding diff."

174

175−write_span_ops :: DisplayContext -> Int -> FixedAttr -> SpanOps -> (Write, FixedAttr)

175+writeSpanOps :: DisplayContext -> Int -> FixedAttr -> SpanOps -> (Write, FixedAttr)

176−write_span_ops dc y in_fattr span_ops =

176+writeSpanOps dc y inFattr spanOps =

177 -- The first operation is to set the cursor to the start of the row

178− let start = write_move_cursor dc 0 y

178+ let start = writeMoveCursor dc 0 y

179 -- then the span ops are serialized in the order specified

180− in Vector.foldl' (\(out, fattr) op -> case write_span_op dc op fattr of

180+ in Vector.foldl' (\(out, fattr) op -> case writeSpanOp dc op fattr of

181− (op_out, fattr') -> (out `mappend` op_out, fattr')

181+ (op_out, fattr') -> (out `mappend` op_out, fattr')

182 )

183− (start, in_fattr)

183+ (start, inFattr)

184− span_ops

184+ spanOps

185

186−write_span_op :: DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)

186+writeSpanOp :: DisplayContext -> SpanOp -> FixedAttr -> (Write, FixedAttr)

187−write_span_op dc (TextSpan attr _ _ str) fattr =

187+writeSpanOp dc (TextSpan attr _ _ str) fattr =

188− let attr' = limit_attr_for_display (context_device dc) attr

188+ let attr' = limitAttrForDisplay (contextDevice dc) attr

189− fattr' = fix_display_attr fattr attr'

189+ fattr' = fixDisplayAttr fattr attr'

190− diffs = display_attr_diffs fattr fattr'

190+ diffs = displayAttrDiffs fattr fattr'

191− out = write_set_attr dc fattr attr' diffs

191+ out = writeSetAttr dc fattr attr' diffs

192− `mappend` write_utf8_text (T.encodeUtf8 $ TL.toStrict str)

192+ `mappend` writeUtf8Text (T.encodeUtf8 $ TL.toStrict str)

193 in (out, fattr')

194−write_span_op _dc (Skip _) _fattr = error "serialize_span_op for Skip"

194+writeSpanOp _dc (Skip _) _fattr = error "serialize_span_op for Skip"

195−write_span_op dc (RowEnd _) fattr = (write_row_end dc, fattr)

195+writeSpanOp dc (RowEnd _) fattr = (writeRowEnd dc, fattr)

196

197-- | The cursor position is given in X,Y character offsets. Due to multi-column characters this

198-- needs to be translated to column, row positions.

199data CursorOutputMap = CursorOutputMap

200− { char_to_output_pos :: (Int, Int) -> (Int, Int)

200+ { charToOutputPos :: (Int, Int) -> (Int, Int)

201 }

202

203−cursor_output_map :: DisplayOps -> Cursor -> CursorOutputMap

203+cursorOutputMap :: DisplayOps -> Cursor -> CursorOutputMap

204−cursor_output_map span_ops _cursor = CursorOutputMap

204+cursorOutputMap spanOps _cursor = CursorOutputMap

205− { char_to_output_pos = \(cx, cy) -> (cursor_column_offset span_ops cx cy, cy)

205+ { charToOutputPos = \(cx, cy) -> (cursorColumnOffset spanOps cx cy, cy)

206 }

207

208−cursor_column_offset :: DisplayOps -> Int -> Int -> Int

208+cursorColumnOffset :: DisplayOps -> Int -> Int -> Int

209−cursor_column_offset ops cx cy =

209+cursorColumnOffset ops cx cy =

210− let cursor_row_ops = Vector.unsafeIndex ops (fromEnum cy)

210+ let cursorRowOps = Vector.unsafeIndex ops (fromEnum cy)

211− (out_offset, _, _)

211+ (outOffset, _, _)

212− = Vector.foldl' ( \(d, current_cx, done) op ->

212+ = Vector.foldl' ( \(d, currentCx, done) op ->

213− if done then (d, current_cx, done) else case span_op_has_width op of

213+ if done then (d, currentCx, done) else case spanOpHasWidth op of

214− Nothing -> (d, current_cx, False)

214+ Nothing -> (d, currentCx, False)

215− Just (cw, ow) -> case compare cx (current_cx + cw) of

215+ Just (cw, ow) -> case compare cx (currentCx + cw) of

216 GT -> ( d + ow

217− , current_cx + cw

217+ , currentCx + cw

218 , False

219 )

220 EQ -> ( d + ow

221− , current_cx + cw

221+ , currentCx + cw

222 , True

223 )

224− LT -> ( d + columns_to_char_offset (cx - current_cx) op

224+ LT -> ( d + columnsToCharOffset (cx - currentCx) op

225− , current_cx + cw

225+ , currentCx + cw

226 , True

227 )

228 )

229 (0, 0, False)

230− cursor_row_ops

230+ cursorRowOps

231− in out_offset

231+ in outOffset

232

233-- | Not all terminals support all display attributes. This filters a display attribute to what the

234-- given terminal can display.

235−limit_attr_for_display :: Output -> Attr -> Attr

235+limitAttrForDisplay :: Output -> Attr -> Attr

236−limit_attr_for_display t attr

236+limitAttrForDisplay t attr

237− = attr { attr_fore_color = clamp_color $ attr_fore_color attr

237+ = attr { attrForeColor = clampColor $ attrForeColor attr

238− , attr_back_color = clamp_color $ attr_back_color attr

238+ , attrBackColor = clampColor $ attrBackColor attr

239 }

240 where

241− clamp_color Default = Default

241+ clampColor Default = Default

242− clamp_color KeepCurrent = KeepCurrent

242+ clampColor KeepCurrent = KeepCurrent

243− clamp_color (SetTo c) = clamp_color' c

243+ clampColor (SetTo c) = clampColor' c

244− clamp_color' (ISOColor v)

244+ clampColor' (ISOColor v)

245− | context_color_count t < 8 = Default

245+ | contextColorCount t < 8 = Default

246− | context_color_count t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)

246+ | contextColorCount t < 16 && v >= 8 = SetTo $ ISOColor (v - 8)

247− | otherwise = SetTo $ ISOColor v

247+ | otherwise = SetTo $ ISOColor v

248− clamp_color' (Color240 v)

248+ clampColor' (Color240 v)

249 -- TODO: Choose closes ISO color?

250− | context_color_count t < 8 = Default

250+ | contextColorCount t < 8 = Default

251− | context_color_count t < 16 = Default

251+ | contextColorCount t < 16 = Default

252− | context_color_count t == 240 = SetTo $ Color240 v

252+ | contextColorCount t == 240 = SetTo $ Color240 v

253 | otherwise

254 = let p :: Double = fromIntegral v / 240.0

255− v' = floor $ p * (fromIntegral $ context_color_count t)

255+ v' = floor $ p * (fromIntegral $ contextColorCount t)

256 in SetTo $ Color240 v'

src/Graphics/Vty/Output/MacOSX.hs+25−25

@@ -8,7 +8,7 @@

8{-# LANGUAGE MagicHash #-}

9{-# LANGUAGE FlexibleInstances #-}

10{-# LANGUAGE TypeFamilies #-}

11−module Graphics.Vty.Output.MacOSX ( reserve_terminal )

11+module Graphics.Vty.Output.MacOSX ( reserveTerminal )

12 where

14import Graphics.Vty.Output.Interface

@@ -23,41 +23,41 @@ import System.IO

23-- "xterm-256color" is used.

24--

25-- This effects the terminfo lookup.

26−reserve_terminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Output

26+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Output

27−reserve_terminal v out_handle = do

27+reserveTerminal v outHandle = do

28− let remap_term "iTerm.app" = "xterm-256color"

28+ let remapTerm "iTerm.app" = "xterm-256color"

29− remap_term _ = "xterm"

29+ remapTerm _ = "xterm"

30− flushed_put :: String -> IO ()

30+ flushedPut :: String -> IO ()

31− flushed_put str = do

31+ flushedPut str = do

32− hPutStr out_handle str

32+ hPutStr outHandle str

33− hFlush out_handle

33+ hFlush outHandle

34− t <- TerminfoBased.reserve_terminal (remap_term v) out_handle

34+ t <- TerminfoBased.reserveTerminal (remapTerm v) outHandle

35− return $ t { terminal_ID = terminal_ID t ++ " (Mac)"

35+ return $ t { terminalID = terminalID t ++ " (Mac)"

36− , reserve_display = terminal_app_reserve_display flushed_put

36+ , reserveDisplay = terminalAppReserveDisplay flushedPut

37− , release_display = terminal_app_release_display flushed_put

37+ , releaseDisplay = terminalAppReleaseDisplay flushedPut

38 }

40-- | Terminal.app requires the xterm-color smcup and rmcup caps. Not the generic xterm ones.

41-- Otherwise, Terminal.app expects the xterm caps.

42−smcup_str, rmcup_str :: String

42+smcupStr, rmcupStr :: String

43−smcup_str = "\ESC7\ESC[?47h"

43+smcupStr = "\ESC7\ESC[?47h"

44−rmcup_str = "\ESC[2J\ESC[?47l\ESC8"

44+rmcupStr = "\ESC[2J\ESC[?47l\ESC8"

46-- | always smcup then clear the screen on terminal.app

47--

48-- \todo really?

49−terminal_app_reserve_display :: MonadIO m => (String -> IO ()) -> m ()

49+terminalAppReserveDisplay :: MonadIO m => (String -> IO ()) -> m ()

50−terminal_app_reserve_display flushed_put = liftIO $ do

50+terminalAppReserveDisplay flushedPut = liftIO $ do

51− flushed_put smcup_str

51+ flushedPut smcupStr

52− flushed_put clear_screen_str

52+ flushedPut clearScreenStr

54−terminal_app_release_display :: MonadIO m => (String -> IO ()) -> m ()

54+terminalAppReleaseDisplay :: MonadIO m => (String -> IO ()) -> m ()

55−terminal_app_release_display flushed_put = liftIO $ do

55+terminalAppReleaseDisplay flushedPut = liftIO $ do

56− flushed_put rmcup_str

56+ flushedPut rmcupStr

58-- | iTerm needs a clear screen after smcup as well.

59--

60-- \todo but we apply to all mac terminals?

61−clear_screen_str :: String

61+clearScreenStr :: String

62−clear_screen_str = "\ESC[H\ESC[2J"

62+clearScreenStr = "\ESC[H\ESC[2J"

src/Graphics/Vty/Output/Mock.hs+27−27

@@ -3,7 +3,7 @@

3{-# LANGUAGE TypeFamilies #-}

4-- | This provides a mock terminal implementation that is nice for testing. This transforms the

5-- output operations to visible characters. Which is nice for some tests.

6−module Graphics.Vty.Output.Mock ( MockData, mock_terminal )

6+module Graphics.Vty.Output.Mock ( MockData, mockTerminal )

7 where

9import Graphics.Vty.Prelude

@@ -32,39 +32,39 @@ type MockData = IORef (UTF8.UTF8 BS.ByteString)

32--

33-- The string representation is a sequence of identifiers where each identifier is the name of an

34-- operation in the algebra.

35−mock_terminal :: (Applicative m, MonadIO m) => DisplayRegion -> m (MockData, Output)

35+mockTerminal :: (Applicative m, MonadIO m) => DisplayRegion -> m (MockData, Output)

36−mock_terminal r = liftIO $ do

36+mockTerminal r = liftIO $ do

37− out_ref <- newIORef undefined

37+ outRef <- newIORef undefined

38− new_assumed_state_ref <- newIORef initial_assumed_state

38+ newAssumedStateRef <- newIORef initialAssumedState

39 let t = Output

40− { terminal_ID = "mock terminal"

40+ { terminalID = "mock terminal"

41− , release_terminal = return ()

41+ , releaseTerminal = return ()

42− , reserve_display = return ()

42+ , reserveDisplay = return ()

43− , release_display = return ()

43+ , releaseDisplay = return ()

44− , display_bounds = return r

44+ , displayBounds = return r

45− , output_byte_buffer = \bytes -> do

45+ , outputByteBuffer = \bytes -> do

46− putStrLn $ "mock output_byte_buffer of " ++ show (BS.length bytes) ++ " bytes"

46+ putStrLn $ "mock outputByteBuffer of " ++ show (BS.length bytes) ++ " bytes"

47− writeIORef out_ref $ UTF8.fromRep bytes

47+ writeIORef outRef $ UTF8.fromRep bytes

48− , context_color_count = 16

48+ , contextColorCount = 16

49− , supports_cursor_visibility = True

49+ , supportsCursorVisibility = True

50− , assumed_state_ref = new_assumed_state_ref

50+ , assumedStateRef = newAssumedStateRef

51− , mk_display_context = \t_actual r_actual -> return $ DisplayContext

51+ , mkDisplayContext = \tActual rActual -> return $ DisplayContext

52− { context_region = r_actual

52+ { contextRegion = rActual

53− , context_device = t_actual

53+ , contextDevice = tActual

54 -- A cursor move is always visualized as the single character 'M'

55− , write_move_cursor = \_x _y -> writeWord8 $ toEnum $ fromEnum 'M'

55+ , writeMoveCursor = \_x _y -> writeWord8 $ toEnum $ fromEnum 'M'

56 -- Show cursor is always visualized as the single character 'S'

57− , write_show_cursor = writeWord8 $ toEnum $ fromEnum 'S'

57+ , writeShowCursor = writeWord8 $ toEnum $ fromEnum 'S'

58 -- Hide cursor is always visualized as the single character 'H'

59− , write_hide_cursor = writeWord8 $ toEnum $ fromEnum 'H'

59+ , writeHideCursor = writeWord8 $ toEnum $ fromEnum 'H'

60 -- An attr change is always visualized as the single character 'A'

61− , write_set_attr = \_fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'

61+ , writeSetAttr = \_fattr _diffs _attr -> writeWord8 $ toEnum $ fromEnum 'A'

62 -- default attr is always visualized as the single character 'D'

63− , write_default_attr = writeWord8 $ toEnum $ fromEnum 'D'

63+ , writeDefaultAttr = writeWord8 $ toEnum $ fromEnum 'D'

64 -- row end is always visualized as the single character 'E'

65− , write_row_end = writeWord8 $ toEnum $ fromEnum 'E'

65+ , writeRowEnd = writeWord8 $ toEnum $ fromEnum 'E'

66− , inline_hack = return ()

66+ , inlineHack = return ()

67 }

68 }

69− return (out_ref, t)

69+ return (outRef, t)

src/Graphics/Vty/Output/TerminfoBased.hs+229−229

@@ -10,7 +10,7 @@

10-- assumptions mixed in.

11--

12-- Copyright Corey O'Connor (coreyoconnor@gmail.com)

13−module Graphics.Vty.Output.TerminfoBased ( reserve_terminal )

13+module Graphics.Vty.Output.TerminfoBased ( reserveTerminal )

14 where

16import Graphics.Vty.Prelude

@@ -65,30 +65,30 @@ data TerminfoCaps = TerminfoCaps

65 , cup :: CapExpression

66 , cnorm :: Maybe CapExpression

67 , civis :: Maybe CapExpression

68− , supports_no_colors :: Bool

68+ , supportsNoColors :: Bool

69− , use_alt_color_map :: Bool

69+ , useAltColorMap :: Bool

70− , set_fore_color :: CapExpression

70+ , setForeColor :: CapExpression

71− , set_back_color :: CapExpression

71+ , setBackColor :: CapExpression

72− , set_default_attr :: CapExpression

72+ , setDefaultAttr :: CapExpression

73− , clear_screen :: CapExpression

73+ , clearScreen :: CapExpression

74− , clear_eol :: CapExpression

74+ , clearEol :: CapExpression

75− , display_attr_caps :: DisplayAttrCaps

75+ , displayAttrCaps :: DisplayAttrCaps

76 }

78data DisplayAttrCaps = DisplayAttrCaps

79− { set_attr_states :: Maybe CapExpression

79+ { setAttrStates :: Maybe CapExpression

80− , enter_standout :: Maybe CapExpression

80+ , enterStandout :: Maybe CapExpression

81− , exit_standout :: Maybe CapExpression

81+ , exitStandout :: Maybe CapExpression

82− , enter_underline :: Maybe CapExpression

82+ , enterUnderline :: Maybe CapExpression

83− , exit_underline :: Maybe CapExpression

83+ , exitUnderline :: Maybe CapExpression

84− , enter_reverse_video :: Maybe CapExpression

84+ , enterReverseVideo :: Maybe CapExpression

85− , enter_dim_mode :: Maybe CapExpression

85+ , enterDimMode :: Maybe CapExpression

86− , enter_bold_mode :: Maybe CapExpression

86+ , enterBoldMode :: Maybe CapExpression

87 }

89−send_cap_to_terminal :: Output -> CapExpression -> [CapParam] -> IO ()

89+sendCapToTerminal :: Output -> CapExpression -> [CapParam] -> IO ()

90−send_cap_to_terminal t cap cap_params = do

90+sendCapToTerminal t cap capParams = do

91− output_byte_buffer t $ writeToByteString $ write_cap_expr cap cap_params

91+ outputByteBuffer t $ writeToByteString $ writeCapExpr cap capParams

93{- | Uses terminfo for all control codes. While this should provide the most compatible terminal

94 - terminfo does not support some features that would increase efficiency and improve compatibility:

@@ -100,136 +100,136 @@ send_cap_to_terminal t cap cap_params = do

100 - todo: Some display attributes like underline and bold have independent string capabilities that

101 - should be used instead of the generic "sgr" string capability.

102 -}

103−reserve_terminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Output

103+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Output

104−reserve_terminal in_ID out_handle = liftIO $ do

104+reserveTerminal inID outHandle = liftIO $ do

105− ti <- Terminfo.setupTerm in_ID

105+ ti <- Terminfo.setupTerm inID

106 -- assumes set foreground always implies set background exists.

107 -- if set foreground is not set then all color changing style attributes are filtered.

108− msetaf <- probe_cap ti "setaf"

108+ msetaf <- probeCap ti "setaf"

109− msetf <- probe_cap ti "setf"

109+ msetf <- probeCap ti "setf"

110− let (no_colors, use_alt, set_fore_cap)

110+ let (noColors, useAlt, setForeCap)

111 = case msetaf of

112 Just setaf -> (False, False, setaf)

113 Nothing -> case msetf of

114 Just setf -> (False, True, setf)

115− Nothing -> (True, True, error $ "no fore color support for terminal " ++ in_ID)

115+ Nothing -> (True, True, error $ "no fore color support for terminal " ++ inID)

116− msetab <- probe_cap ti "setab"

116+ msetab <- probeCap ti "setab"

117− msetb <- probe_cap ti "setb"

117+ msetb <- probeCap ti "setb"

118 let set_back_cap

119 = case msetab of

120 Nothing -> case msetb of

121 Just setb -> setb

122− Nothing -> error $ "no back color support for terminal " ++ in_ID

122+ Nothing -> error $ "no back color support for terminal " ++ inID

123 Just setab -> setab

124− terminfo_caps <- pure TerminfoCaps

124+ terminfoCaps <- pure TerminfoCaps

125− <*> probe_cap ti "smcup"

125+ <*> probeCap ti "smcup"

126− <*> probe_cap ti "rmcup"

126+ <*> probeCap ti "rmcup"

127− <*> require_cap ti "cup"

127+ <*> requireCap ti "cup"

128− <*> probe_cap ti "cnorm"

128+ <*> probeCap ti "cnorm"

129− <*> probe_cap ti "civis"

129+ <*> probeCap ti "civis"

130− <*> pure no_colors

130+ <*> pure noColors

131− <*> pure use_alt

131+ <*> pure useAlt

132− <*> pure set_fore_cap

132+ <*> pure setForeCap

133 <*> pure set_back_cap

134− <*> require_cap ti "sgr0"

134+ <*> requireCap ti "sgr0"

135− <*> require_cap ti "clear"

135+ <*> requireCap ti "clear"

136− <*> require_cap ti "el"

136+ <*> requireCap ti "el"

137− <*> current_display_attr_caps ti

137+ <*> currentDisplayAttrCaps ti

138− new_assumed_state_ref <- newIORef initial_assumed_state

138+ newAssumedStateRef <- newIORef initialAssumedState

139 let t = Output

140− { terminal_ID = in_ID

140+ { terminalID = inID

141− , release_terminal = liftIO $ do

141+ , releaseTerminal = liftIO $ do

142− send_cap set_default_attr []

142+ sendCap setDefaultAttr []

143− maybe_send_cap cnorm []

143+ maybeSendCap cnorm []

144− hClose out_handle

144+ hClose outHandle

145− , reserve_display = liftIO $ do

145+ , reserveDisplay = liftIO $ do

146 -- If there is no support for smcup: Clear the screen and then move the mouse to the

147 -- home position to approximate the behavior.

148− maybe_send_cap smcup []

148+ maybeSendCap smcup []

149− hFlush out_handle

149+ hFlush outHandle

150− send_cap clear_screen []

150+ sendCap clearScreen []

151− , release_display = liftIO $ do

151+ , releaseDisplay = liftIO $ do

152− maybe_send_cap rmcup []

152+ maybeSendCap rmcup []

153− maybe_send_cap cnorm []

153+ maybeSendCap cnorm []

154− , display_bounds = do

154+ , displayBounds = do

155− raw_size <- liftIO $ withFd out_handle get_window_size

155+ rawSize <- liftIO $ withFd outHandle getWindowSize

156− case raw_size of

156+ case rawSize of

157− (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show raw_size

157+ (w, h) | w < 0 || h < 0 -> fail $ "getwinsize returned < 0 : " ++ show rawSize

158 | otherwise -> return (w,h)

159− , output_byte_buffer = \out_bytes -> do

159+ , outputByteBuffer = \outBytes -> do

160− BS.hPut out_handle out_bytes

160+ BS.hPut outHandle outBytes

161− hFlush out_handle

161+ hFlush outHandle

162− , context_color_count

162+ , contextColorCount

163− = case supports_no_colors terminfo_caps of

163+ = case supportsNoColors terminfoCaps of

164 False -> case Terminfo.getCapability ti (Terminfo.tiGetNum "colors" ) of

165 Nothing -> 8

166 Just v -> toEnum v

167 True -> 1

168− , supports_cursor_visibility = isJust $ civis terminfo_caps

168+ , supportsCursorVisibility = isJust $ civis terminfoCaps

169− , assumed_state_ref = new_assumed_state_ref

169+ , assumedStateRef = newAssumedStateRef

170− -- I think fix would help assure t_actual is the only reference. I was having issues

170+ -- I think fix would help assure tActual is the only reference. I was having issues

171 -- tho.

172− , mk_display_context = \t_actual -> liftIO . terminfo_display_context t_actual terminfo_caps

172+ , mkDisplayContext = \tActual -> liftIO . terminfoDisplayContext tActual terminfoCaps

173 }

174− send_cap s = send_cap_to_terminal t (s terminfo_caps)

174+ sendCap s = sendCapToTerminal t (s terminfoCaps)

175− maybe_send_cap s = when (isJust $ s terminfo_caps) . send_cap (fromJust . s)

175+ maybeSendCap s = when (isJust $ s terminfoCaps) . sendCap (fromJust . s)

176 return t

177

178−require_cap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression

178+requireCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m CapExpression

179−require_cap ti cap_name

179+requireCap ti capName

180− = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of

180+ = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of

181− Nothing -> fail $ "Terminal does not define required capability \"" ++ cap_name ++ "\""

181+ Nothing -> fail $ "Terminal does not define required capability \"" ++ capName ++ "\""

182− Just cap_str -> parse_cap cap_str

182+ Just capStr -> parseCap capStr

183

184−probe_cap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)

184+probeCap :: (Applicative m, MonadIO m) => Terminfo.Terminal -> String -> m (Maybe CapExpression)

185−probe_cap ti cap_name

185+probeCap ti capName

186− = case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of

186+ = case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of

187− Nothing -> return Nothing

187+ Nothing -> return Nothing

188− Just cap_str -> Just <$> parse_cap cap_str

188+ Just capStr -> Just <$> parseCap capStr

189

190−parse_cap :: (Applicative m, MonadIO m) => String -> m CapExpression

190+parseCap :: (Applicative m, MonadIO m) => String -> m CapExpression

191−parse_cap cap_str = do

191+parseCap capStr = do

192− case parse_cap_expression cap_str of

192+ case parseCapExpression capStr of

193 Left e -> fail $ show e

194 Right cap -> return cap

195

196−current_display_attr_caps :: ( Applicative m, MonadIO m )

196+currentDisplayAttrCaps :: ( Applicative m, MonadIO m )

197− => Terminfo.Terminal

197+ => Terminfo.Terminal

198− -> m DisplayAttrCaps

198+ -> m DisplayAttrCaps

199−current_display_attr_caps ti

199+currentDisplayAttrCaps ti

200 = pure DisplayAttrCaps

201− <*> probe_cap ti "sgr"

201+ <*> probeCap ti "sgr"

202− <*> probe_cap ti "smso"

202+ <*> probeCap ti "smso"

203− <*> probe_cap ti "rmso"

203+ <*> probeCap ti "rmso"

204− <*> probe_cap ti "smul"

204+ <*> probeCap ti "smul"

205− <*> probe_cap ti "rmul"

205+ <*> probeCap ti "rmul"

206− <*> probe_cap ti "rev"

206+ <*> probeCap ti "rev"

207− <*> probe_cap ti "dim"

207+ <*> probeCap ti "dim"

208− <*> probe_cap ti "bold"

208+ <*> probeCap ti "bold"

209

210−foreign import ccall "gwinsz.h vty_c_get_window_size" c_get_window_size :: Fd -> IO CLong

210+foreign import ccall "gwinsz.h vty_c_get_window_size" c_getWindowSize :: Fd -> IO CLong

211

212−get_window_size :: Fd -> IO (Int,Int)

212+getWindowSize :: Fd -> IO (Int,Int)

213−get_window_size fd = do

213+getWindowSize fd = do

214− (a,b) <- (`divMod` 65536) `fmap` c_get_window_size fd

214+ (a,b) <- (`divMod` 65536) `fmap` c_getWindowSize fd

215 return (fromIntegral b, fromIntegral a)

216

217−terminfo_display_context :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext

217+terminfoDisplayContext :: Output -> TerminfoCaps -> DisplayRegion -> IO DisplayContext

218−terminfo_display_context t_actual terminfo_caps r = return dc

218+terminfoDisplayContext tActual terminfoCaps r = return dc

219 where dc = DisplayContext

220− { context_device = t_actual

220+ { contextDevice = tActual

221− , context_region = r

221+ , contextRegion = r

222− , write_move_cursor = \x y -> write_cap_expr (cup terminfo_caps) [toEnum y, toEnum x]

222+ , writeMoveCursor = \x y -> writeCapExpr (cup terminfoCaps) [toEnum y, toEnum x]

223− , write_show_cursor = case cnorm terminfo_caps of

223+ , writeShowCursor = case cnorm terminfoCaps of

224 Nothing -> error "this terminal does not support show cursor"

225− Just c -> write_cap_expr c []

225+ Just c -> writeCapExpr c []

226− , write_hide_cursor = case civis terminfo_caps of

226+ , writeHideCursor = case civis terminfoCaps of

227 Nothing -> error "this terminal does not support hide cursor"

228− Just c -> write_cap_expr c []

228+ Just c -> writeCapExpr c []

229− , write_set_attr = terminfo_write_set_attr dc terminfo_caps

229+ , writeSetAttr = terminfoWriteSetAttr dc terminfoCaps

230− , write_default_attr = write_cap_expr (set_default_attr terminfo_caps) []

230+ , writeDefaultAttr = writeCapExpr (setDefaultAttr terminfoCaps) []

231− , write_row_end = write_cap_expr (clear_eol terminfo_caps) []

231+ , writeRowEnd = writeCapExpr (clearEol terminfoCaps) []

232− , inline_hack = return ()

232+ , inlineHack = return ()

233 }

234

235-- | Portably setting the display attributes is a giant pain in the ass.

@@ -255,102 +255,102 @@ terminfo_display_context t_actual terminfo_caps r = return dc

255-- This equation implements the above logic.

256--

257-- \todo This assumes the removal of color changes in the display attributes is done as expected

258−-- with no_colors == True. See `limit_attr_for_display`

258+-- with noColors == True. See `limit_attr_for_display`

259--

260-- \todo This assumes that fewer state changes, followed by fewer bytes, is what to optimize. I

261-- haven't measured this or even examined terminal implementations. *shrug*

262−terminfo_write_set_attr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write

262+terminfoWriteSetAttr :: DisplayContext -> TerminfoCaps -> FixedAttr -> Attr -> DisplayAttrDiff -> Write

263−terminfo_write_set_attr dc terminfo_caps prev_attr req_attr diffs = do

263+terminfoWriteSetAttr dc terminfoCaps prevAttr reqAttr diffs = do

264− case (fore_color_diff diffs == ColorToDefault) || (back_color_diff diffs == ColorToDefault) of

264+ case (foreColorDiff diffs == ColorToDefault) || (backColorDiff diffs == ColorToDefault) of

265 -- The only way to reset either color, portably, to the default is to use either the set

266 -- state capability or the set default capability.

267 True -> do

268− case req_display_cap_seq_for (display_attr_caps terminfo_caps)

268+ case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)

269− (fixed_style attr )

269+ (fixedStyle attr )

270− (style_to_apply_seq $ fixed_style attr) of

270+ (styleToApplySeq $ fixedStyle attr) of

271 -- only way to reset a color to the defaults

272− EnterExitSeq caps -> write_default_attr dc

272+ EnterExitSeq caps -> writeDefaultAttr dc

273 `mappend`

274− foldMap (\cap -> write_cap_expr cap []) caps

274+ foldMap (\cap -> writeCapExpr cap []) caps

275 `mappend`

276− set_colors

276+ setColors

277 -- implicitly resets the colors to the defaults

278− SetState state -> write_cap_expr (fromJust $ set_attr_states

278+ SetState state -> writeCapExpr (fromJust $ setAttrStates

279− $ display_attr_caps

279+ $ displayAttrCaps

280− $ terminfo_caps

280+ $ terminfoCaps

281− )

281+ )

282− (sgr_args_for_state state)

282+ (sgrArgsForState state)

283 `mappend`

284− set_colors

284+ setColors

285 -- Otherwise the display colors are not changing or changing between two non-default

286 -- points.

287 False -> do

288 -- Still, it could be the case that the change in display attributes requires the

289 -- colors to be reset because the required capability was not available.

290− case req_display_cap_seq_for (display_attr_caps terminfo_caps)

290+ case reqDisplayCapSeqFor (displayAttrCaps terminfoCaps)

291− (fixed_style attr)

291+ (fixedStyle attr)

292− (style_diffs diffs) of

292+ (styleDiffs diffs) of

293 -- Really, if terminals were re-implemented with modern concepts instead of bowing

294 -- down to 40 yr old dumb terminal requirements this would be the only case ever

295 -- reached! Changes the style and color states according to the differences with

296 -- the currently applied states.

297− EnterExitSeq caps -> foldMap (\cap -> write_cap_expr cap []) caps

297+ EnterExitSeq caps -> foldMap (\cap -> writeCapExpr cap []) caps

298 `mappend`

299− write_color_diff set_fore_color (fore_color_diff diffs)

299+ writeColorDiff setForeColor (foreColorDiff diffs)

300 `mappend`

301− write_color_diff set_back_color (back_color_diff diffs)

301+ writeColorDiff setBackColor (backColorDiff diffs)

302 -- implicitly resets the colors to the defaults

303− SetState state -> write_cap_expr (fromJust $ set_attr_states

303+ SetState state -> writeCapExpr (fromJust $ setAttrStates

304− $ display_attr_caps terminfo_caps

304+ $ displayAttrCaps terminfoCaps

305− )

305+ )

306− (sgr_args_for_state state)

306+ (sgrArgsForState state)

307− `mappend` set_colors

307+ `mappend` setColors

308 where

309− color_map = case use_alt_color_map terminfo_caps of

309+ colorMap = case useAltColorMap terminfoCaps of

310− False -> ansi_color_index

310+ False -> ansiColorIndex

311− True -> alt_color_index

311+ True -> altColorIndex

312− attr = fix_display_attr prev_attr req_attr

312+ attr = fixDisplayAttr prevAttr reqAttr

313− set_colors =

313+ setColors =

314− (case fixed_fore_color attr of

314+ (case fixedForeColor attr of

315− Just c -> write_cap_expr (set_fore_color terminfo_caps)

315+ Just c -> writeCapExpr (setForeColor terminfoCaps)

316− [toEnum $ color_map c]

316+ [toEnum $ colorMap c]

317 Nothing -> mempty)

318 `mappend`

319− (case fixed_back_color attr of

319+ (case fixedBackColor attr of

320− Just c -> write_cap_expr (set_back_color terminfo_caps)

320+ Just c -> writeCapExpr (setBackColor terminfoCaps)

321− [toEnum $ color_map c]

321+ [toEnum $ colorMap c]

322 Nothing -> mempty)

323− write_color_diff _f NoColorChange

323+ writeColorDiff _f NoColorChange

324 = mempty

325− write_color_diff _f ColorToDefault

325+ writeColorDiff _f ColorToDefault

326− = error "ColorToDefault is not a possible case for apply_color_diffs"

326+ = error "ColorToDefault is not a possible case for applyColorDiffs"

327− write_color_diff f (SetColor c)

327+ writeColorDiff f (SetColor c)

328− = write_cap_expr (f terminfo_caps) [toEnum $ color_map c]

328+ = writeCapExpr (f terminfoCaps) [toEnum $ colorMap c]

329

330-- | The color table used by a terminal is a 16 color set followed by a 240 color set that might not

331-- be supported by the terminal.

332--

333-- This takes a Color which clearly identifies which pallete to use and computes the index

334-- into the full 256 color pallete.

335−ansi_color_index :: Color -> Int

335+ansiColorIndex :: Color -> Int

336−ansi_color_index (ISOColor v) = fromEnum v

336+ansiColorIndex (ISOColor v) = fromEnum v

337−ansi_color_index (Color240 v) = 16 + fromEnum v

337+ansiColorIndex (Color240 v) = 16 + fromEnum v

338

339-- | For terminals without setaf/setab

340--

341-- See table in `man terminfo`

342-- Will error if not in table.

343−alt_color_index :: Color -> Int

343+altColorIndex :: Color -> Int

344−alt_color_index (ISOColor 0) = 0

344+altColorIndex (ISOColor 0) = 0

345−alt_color_index (ISOColor 1) = 4

345+altColorIndex (ISOColor 1) = 4

346−alt_color_index (ISOColor 2) = 2

346+altColorIndex (ISOColor 2) = 2

347−alt_color_index (ISOColor 3) = 6

347+altColorIndex (ISOColor 3) = 6

348−alt_color_index (ISOColor 4) = 1

348+altColorIndex (ISOColor 4) = 1

349−alt_color_index (ISOColor 5) = 5

349+altColorIndex (ISOColor 5) = 5

350−alt_color_index (ISOColor 6) = 3

350+altColorIndex (ISOColor 6) = 3

351−alt_color_index (ISOColor 7) = 7

351+altColorIndex (ISOColor 7) = 7

352−alt_color_index (ISOColor v) = fromEnum v

352+altColorIndex (ISOColor v) = fromEnum v

353−alt_color_index (Color240 v) = 16 + fromEnum v

353+altColorIndex (Color240 v) = 16 + fromEnum v

354

355{- | The sequence of terminfo caps to apply a given style are determined according to these rules.

356 -

@@ -372,85 +372,85 @@ data DisplayAttrSeq

372 | SetState DisplayAttrState

373

374data DisplayAttrState = DisplayAttrState

375− { apply_standout :: Bool

375+ { applyStandout :: Bool

376− , apply_underline :: Bool

376+ , applyUnderline :: Bool

377− , apply_reverse_video :: Bool

377+ , applyReverseVideo :: Bool

378− , apply_blink :: Bool

378+ , applyBlink :: Bool

379− , apply_dim :: Bool

379+ , applyDim :: Bool

380− , apply_bold :: Bool

380+ , applyBold :: Bool

381 }

382

383−sgr_args_for_state :: DisplayAttrState -> [CapParam]

383+sgrArgsForState :: DisplayAttrState -> [CapParam]

384−sgr_args_for_state attr_state = map (\b -> if b then 1 else 0)

384+sgrArgsForState attrState = map (\b -> if b then 1 else 0)

385− [ apply_standout attr_state

385+ [ applyStandout attrState

386− , apply_underline attr_state

386+ , applyUnderline attrState

387− , apply_reverse_video attr_state

387+ , applyReverseVideo attrState

388− , apply_blink attr_state

388+ , applyBlink attrState

389− , apply_dim attr_state

389+ , applyDim attrState

390− , apply_bold attr_state

390+ , applyBold attrState

391 , False -- invis

392 , False -- protect

393 , False -- alt char set

394 ]

395

396−req_display_cap_seq_for :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq

396+reqDisplayCapSeqFor :: DisplayAttrCaps -> Style -> [StyleStateChange] -> DisplayAttrSeq

397−req_display_cap_seq_for caps s diffs

397+reqDisplayCapSeqFor caps s diffs

398 -- if the state transition implied by any diff cannot be supported with an enter/exit mode cap

399 -- then either the state needs to be set or the attribute change ignored.

400− = case (any no_enter_exit_cap diffs, isJust $ set_attr_states caps) of

400+ = case (any noEnterExitCap diffs, isJust $ setAttrStates caps) of

401 -- If all the diffs have an enter-exit cap then just use those

402− ( False, _ ) -> EnterExitSeq $ map enter_exit_cap diffs

402+ ( False, _ ) -> EnterExitSeq $ map enterExitCap diffs

403 -- If not all the diffs have an enter-exit cap and there is no set state cap then filter out

404 -- all unsupported diffs and just apply the rest

405− ( True, False ) -> EnterExitSeq $ map enter_exit_cap

405+ ( True, False ) -> EnterExitSeq $ map enterExitCap

406− $ filter (not . no_enter_exit_cap) diffs

406+ $ filter (not . noEnterExitCap) diffs

407 -- if not all the diffs have an enter-exit can and there is a set state cap then just use

408 -- the set state cap.

409− ( True, True ) -> SetState $ state_for_style s

409+ ( True, True ) -> SetState $ stateForStyle s

410 where

411− no_enter_exit_cap ApplyStandout = isNothing $ enter_standout caps

411+ noEnterExitCap ApplyStandout = isNothing $ enterStandout caps

412− no_enter_exit_cap RemoveStandout = isNothing $ exit_standout caps

412+ noEnterExitCap RemoveStandout = isNothing $ exitStandout caps

413− no_enter_exit_cap ApplyUnderline = isNothing $ enter_underline caps

413+ noEnterExitCap ApplyUnderline = isNothing $ enterUnderline caps

414− no_enter_exit_cap RemoveUnderline = isNothing $ exit_underline caps

414+ noEnterExitCap RemoveUnderline = isNothing $ exitUnderline caps

415− no_enter_exit_cap ApplyReverseVideo = isNothing $ enter_reverse_video caps

415+ noEnterExitCap ApplyReverseVideo = isNothing $ enterReverseVideo caps

416− no_enter_exit_cap RemoveReverseVideo = True

416+ noEnterExitCap RemoveReverseVideo = True

417− no_enter_exit_cap ApplyBlink = True

417+ noEnterExitCap ApplyBlink = True

418− no_enter_exit_cap RemoveBlink = True

418+ noEnterExitCap RemoveBlink = True

419− no_enter_exit_cap ApplyDim = isNothing $ enter_dim_mode caps

419+ noEnterExitCap ApplyDim = isNothing $ enterDimMode caps

420− no_enter_exit_cap RemoveDim = True

420+ noEnterExitCap RemoveDim = True

421− no_enter_exit_cap ApplyBold = isNothing $ enter_bold_mode caps

421+ noEnterExitCap ApplyBold = isNothing $ enterBoldMode caps

422− no_enter_exit_cap RemoveBold = True

422+ noEnterExitCap RemoveBold = True

423− enter_exit_cap ApplyStandout = fromJust $ enter_standout caps

423+ enterExitCap ApplyStandout = fromJust $ enterStandout caps

424− enter_exit_cap RemoveStandout = fromJust $ exit_standout caps

424+ enterExitCap RemoveStandout = fromJust $ exitStandout caps

425− enter_exit_cap ApplyUnderline = fromJust $ enter_underline caps

425+ enterExitCap ApplyUnderline = fromJust $ enterUnderline caps

426− enter_exit_cap RemoveUnderline = fromJust $ exit_underline caps

426+ enterExitCap RemoveUnderline = fromJust $ exitUnderline caps

427− enter_exit_cap ApplyReverseVideo = fromJust $ enter_reverse_video caps

427+ enterExitCap ApplyReverseVideo = fromJust $ enterReverseVideo caps

428− enter_exit_cap ApplyDim = fromJust $ enter_dim_mode caps

428+ enterExitCap ApplyDim = fromJust $ enterDimMode caps

429− enter_exit_cap ApplyBold = fromJust $ enter_bold_mode caps

429+ enterExitCap ApplyBold = fromJust $ enterBoldMode caps

430− enter_exit_cap _ = error "enter_exit_cap applied to diff that was known not to have one."

430+ enterExitCap _ = error "enterExitCap applied to diff that was known not to have one."

431

432−state_for_style :: Style -> DisplayAttrState

432+stateForStyle :: Style -> DisplayAttrState

433−state_for_style s = DisplayAttrState

433+stateForStyle s = DisplayAttrState

434− { apply_standout = is_style_set standout

434+ { applyStandout = isStyleSet standout

435− , apply_underline = is_style_set underline

435+ , applyUnderline = isStyleSet underline

436− , apply_reverse_video = is_style_set reverse_video

436+ , applyReverseVideo = isStyleSet reverseVideo

437− , apply_blink = is_style_set blink

437+ , applyBlink = isStyleSet blink

438− , apply_dim = is_style_set dim

438+ , applyDim = isStyleSet dim

439− , apply_bold = is_style_set bold

439+ , applyBold = isStyleSet bold

440 }

441− where is_style_set = has_style s

441+ where isStyleSet = hasStyle s

442

443−style_to_apply_seq :: Style -> [StyleStateChange]

443+styleToApplySeq :: Style -> [StyleStateChange]

444−style_to_apply_seq s = concat

444+styleToApplySeq s = concat

445− [ apply_if_required ApplyStandout standout

445+ [ applyIfRequired ApplyStandout standout

446− , apply_if_required ApplyUnderline underline

446+ , applyIfRequired ApplyUnderline underline

447− , apply_if_required ApplyReverseVideo reverse_video

447+ , applyIfRequired ApplyReverseVideo reverseVideo

448− , apply_if_required ApplyBlink blink

448+ , applyIfRequired ApplyBlink blink

449− , apply_if_required ApplyDim dim

449+ , applyIfRequired ApplyDim dim

450− , apply_if_required ApplyBlink bold

450+ , applyIfRequired ApplyBlink bold

451 ]

452 where

453− apply_if_required op flag

453+ applyIfRequired op flag

454 = if 0 == (flag .&. s)

455 then []

456 else [op]

src/Graphics/Vty/Output/XTermColor.hs+22−22

@@ -1,5 +1,5 @@

2−module Graphics.Vty.Output.XTermColor ( reserve_terminal )

2+module Graphics.Vty.Output.XTermColor ( reserveTerminal )

3 where

5import Graphics.Vty.Output.Interface

@@ -16,39 +16,39 @@ import Data.Foldable (foldMap)

16import System.IO

18-- | Initialize the display to UTF-8.

19−reserve_terminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Output

19+reserveTerminal :: ( Applicative m, MonadIO m ) => String -> Handle -> m Output

20−reserve_terminal variant out_handle = liftIO $ do

20+reserveTerminal variant outHandle = liftIO $ do

21− let flushed_put str = do

21+ let flushedPut str = do

22− hPutStr out_handle str

22+ hPutStr outHandle str

23− hFlush out_handle

23+ hFlush outHandle

24 -- If the terminal variant is xterm-color use xterm instead since, more often than not,

25 -- xterm-color is broken.

26 let variant' = if variant == "xterm-color" then "xterm" else variant

27− flushed_put set_utf8_char_set

27+ flushedPut setUtf8CharSet

28− t <- TerminfoBased.reserve_terminal variant' out_handle

28+ t <- TerminfoBased.reserveTerminal variant' outHandle

29 let t' = t

30− { terminal_ID = terminal_ID t ++ " (xterm-color)"

30+ { terminalID = terminalID t ++ " (xterm-color)"

31− , release_terminal = do

31+ , releaseTerminal = do

32− liftIO $ flushed_put set_default_char_set

32+ liftIO $ flushedPut setDefaultCharSet

33− release_terminal t

33+ releaseTerminal t

34− , mk_display_context = \t_actual r -> do

34+ , mkDisplayContext = \tActual r -> do

35− dc <- mk_display_context t t_actual r

35+ dc <- mkDisplayContext t tActual r

36− return $ dc { inline_hack = xterm_inline_hack t' }

36+ return $ dc { inlineHack = xtermInlineHack t' }

37 }

38 return t'

40-- | These sequences set xterm based terminals to UTF-8 output.

41--

42-- \todo I don't know of a terminfo cap that is equivalent to this.

43−set_utf8_char_set, set_default_char_set :: String

43+setUtf8CharSet, setDefaultCharSet :: String

44−set_utf8_char_set = "\ESC%G"

44+setUtf8CharSet = "\ESC%G"

45−set_default_char_set = "\ESC%@"

45+setDefaultCharSet = "\ESC%@"

47-- | I think xterm is broken: Reseting the background color as the first bytes serialized on a

48-- new line does not effect the background color xterm uses to clear the line. Which is used

49-- *after* the next newline.

50−xterm_inline_hack :: Output -> IO ()

50+xtermInlineHack :: Output -> IO ()

51−xterm_inline_hack t = do

51+xtermInlineHack t = do

52− let write_reset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"

52+ let writeReset = foldMap (writeWord8.toEnum.fromEnum) "\ESC[K"

53− output_byte_buffer t $ writeToByteString write_reset

53+ outputByteBuffer t $ writeToByteString writeReset

src/Graphics/Vty/Picture.hs+25−25

@@ -13,12 +13,12 @@ import Control.DeepSeq

14-- | The type of images to be displayed using 'update'.

15--

16−-- Can be constructed directly or using `pic_for_image`. Which provides an initial instance with

16+-- Can be constructed directly or using `picForImage`. Which provides an initial instance with

17−-- reasonable defaults for pic_cursor and pic_background.

17+-- reasonable defaults for picCursor and picBackground.

18data Picture = Picture

19− { pic_cursor :: Cursor

19+ { picCursor :: Cursor

20− , pic_layers :: [Image]

20+ , picLayers :: [Image]

21− , pic_background :: Background

21+ , picBackground :: Background

22 }

24instance Show Picture where

@@ -28,24 +28,24 @@ instance NFData Picture where

28 rnf (Picture c l b) = c `deepseq` l `deepseq` b `deepseq` ()

30-- | a picture with no cursor, background or image layers

31−empty_picture :: Picture

31+emptyPicture :: Picture

32−empty_picture = Picture NoCursor [] ClearBackground

32+emptyPicture = Picture NoCursor [] ClearBackground

34-- | The given 'Image' is added as the top layer of the 'Picture'

35−add_to_top :: Picture -> Image -> Picture

35+addToTop :: Picture -> Image -> Picture

36−add_to_top p i = p {pic_layers = i : pic_layers p}

36+addToTop p i = p {picLayers = i : picLayers p}

38-- | The given 'Image' is added as the bottom layer of the 'Picture'

39−add_to_bottom :: Picture -> Image -> Picture

39+addToBottom :: Picture -> Image -> Picture

40−add_to_bottom p i = p {pic_layers = pic_layers p ++ [i]}

40+addToBottom p i = p {picLayers = picLayers p ++ [i]}

42-- | Create a picture for display for the given image. The picture will not have a displayed cursor

43-- and no background pattern (ClearBackground) will be used.

44−pic_for_image :: Image -> Picture

44+picForImage :: Image -> Picture

45−pic_for_image i = Picture

45+picForImage i = Picture

46− { pic_cursor = NoCursor

46+ { picCursor = NoCursor

47− , pic_layers = [i]

47+ , picLayers = [i]

48− , pic_background = ClearBackground

48+ , picBackground = ClearBackground

49 }

51-- | Create a picture for display with the given layers. Ordered top to bottom.

@@ -54,11 +54,11 @@ pic_for_image i = Picture

54-- used.

55--

56-- The first 'Image' is the top layer.

57−pic_for_layers :: [Image] -> Picture

57+picForLayers :: [Image] -> Picture

58−pic_for_layers is = Picture

58+picForLayers is = Picture

59− { pic_cursor = NoCursor

59+ { picCursor = NoCursor

60− , pic_layers = is

60+ , picLayers = is

61− , pic_background = ClearBackground

61+ , picBackground = ClearBackground

62 }

64-- | A picture can be configured either to not show the cursor or show the cursor at the specified

@@ -86,8 +86,8 @@ instance NFData Cursor where

86-- screen to a picture.

87data Background

88 = Background

89− { background_char :: Char

89+ { backgroundChar :: Char

90− , background_attr :: Attr

90+ , backgroundAttr :: Attr

91 }

92 -- | A ClearBackground is:

93 --

@@ -101,5 +101,5 @@ instance NFData Background where

101 rnf ClearBackground = ()

102

103-- | Compatibility with applications that do not use more than a single layer.

104−pic_image :: Picture -> Image

104+picImage :: Picture -> Image

105−pic_image = head . pic_layers

105+picImage = head . picLayers

src/Graphics/Vty/PictureToSpans.hs+167−167

@@ -33,29 +33,29 @@ type MSpanOps s = MVector s SpanOp

34-- transform plus clip. More or less.

35data BlitState = BlitState

36− -- we always snoc to the operation vectors. Thus the column_offset = length of row at row_offset

36+ -- we always snoc to the operation vectors. Thus the columnOffset = length of row at rowOffset

37− -- although, one possibility is to merge layers right in snoc_op (naming it something else, of

37+ -- although, one possibility is to merge layers right in snocOp (naming it something else, of

38− -- course). In which case columnn_offset would be applicable.

38+ -- course). In which case columnnOffset would be applicable.

39 -- Right now we need it to exist.

40− { _column_offset :: Int

40+ { _columnOffset :: Int

41− , _row_offset :: Int

41+ , _rowOffset :: Int

42− -- clip coordinate space is in image space. Which means it's >= 0 and < image_width.

42+ -- clip coordinate space is in image space. Which means it's >= 0 and < imageWidth.

43− , _skip_columns :: Int

43+ , _skipColumns :: Int

44− -- >= 0 and < image_height

44+ -- >= 0 and < imageHeight

45− , _skip_rows :: Int

45+ , _skipRows :: Int

46− -- includes consideration of skip_columns. In display space.

46+ -- includes consideration of skipColumns. In display space.

47 -- The number of columns from the next column to be defined to the end of the display for the

48 -- row.

49− , _remaining_columns :: Int

49+ , _remainingColumns :: Int

50− -- includes consideration of skip_rows. In display space.

50+ -- includes consideration of skipRows. In display space.

51− , _remaining_rows :: Int

51+ , _remainingRows :: Int

52 }

54makeLenses ''BlitState

56data BlitEnv s = BlitEnv

57 { _region :: DisplayRegion

58− , _mrow_ops :: MRowOps s

58+ , _mrowOps :: MRowOps s

59 }

61makeLenses ''BlitEnv

@@ -64,105 +64,105 @@ type BlitM s a = ReaderT (BlitEnv s) (StateT BlitState (ST s)) a

65-- | Produces the span ops that will render the given picture, possibly cropped or padded, into the

66-- specified region.

67−display_ops_for_pic :: Picture -> DisplayRegion -> DisplayOps

67+displayOpsForPic :: Picture -> DisplayRegion -> DisplayOps

68−display_ops_for_pic pic r = Vector.create (combined_ops_for_layers pic r)

68+displayOpsForPic pic r = Vector.create (combinedOpsForLayers pic r)

70-- | Returns the DisplayOps for an image rendered to a window the size of the image.

71--

72-- largerly used only for debugging.

73−display_ops_for_image :: Image -> DisplayOps

73+displayOpsForImage :: Image -> DisplayOps

74−display_ops_for_image i = display_ops_for_pic (pic_for_image i) (image_width i, image_height i)

74+displayOpsForImage i = displayOpsForPic (picForImage i) (imageWidth i, imageHeight i)

76-- | Produces the span ops for each layer then combines them.

77--

78-- TODO: a fold over a builder function. start with span ops that are a bg fill of the entire

79-- region.

80−combined_ops_for_layers :: Picture -> DisplayRegion -> ST s (MRowOps s)

80+combinedOpsForLayers :: Picture -> DisplayRegion -> ST s (MRowOps s)

81−combined_ops_for_layers pic r

81+combinedOpsForLayers pic r

82− | region_width r == 0 || region_height r == 0 = MVector.new 0

82+ | regionWidth r == 0 || regionHeight r == 0 = MVector.new 0

83 | otherwise = do

84− layer_ops <- mapM (\layer -> build_spans layer r) (pic_layers pic)

84+ layerOps <- mapM (\layer -> buildSpans layer r) (picLayers pic)

85− case layer_ops of

85+ case layerOps of

86 [] -> fail "empty picture"

87− [ops] -> substitute_skips (pic_background pic) ops

87+ [ops] -> substituteSkips (picBackground pic) ops

88 -- instead of merging ops after generation the merging can be performed as part of

89− -- snoc_op.

89+ -- snocOp.

90− top_ops : lower_ops -> do

90+ topOps : lowerOps -> do

91− ops <- foldM merge_under top_ops lower_ops

91+ ops <- foldM mergeUnder topOps lowerOps

92− substitute_skips (pic_background pic) ops

92+ substituteSkips (picBackground pic) ops

94−substitute_skips :: Background -> MRowOps s -> ST s (MRowOps s)

94+substituteSkips :: Background -> MRowOps s -> ST s (MRowOps s)

95−substitute_skips ClearBackground ops = do

95+substituteSkips ClearBackground ops = do

96 forM_ [0 .. MVector.length ops - 1] $ \row -> do

97− row_ops <- MVector.read ops row

97+ rowOps <- MVector.read ops row

98 -- the image operations assure that background fills are combined.

99 -- clipping a background fill does not split the background fill.

100 -- merging of image layers can split a skip, but only by the insertion of a non skip.

101 -- all this combines to mean we can check the last operation and remove it if it's a skip

102 -- todo: or does it?

103− let row_ops' = case Vector.last row_ops of

103+ let rowOps' = case Vector.last rowOps of

104− Skip w -> Vector.init row_ops `Vector.snoc` RowEnd w

104+ Skip w -> Vector.init rowOps `Vector.snoc` RowEnd w

105− _ -> row_ops

105+ _ -> rowOps

106 -- now all the skips can be replaced by replications of ' ' of the required width.

107− let row_ops'' = swap_skips_for_single_column_char_span ' ' current_attr row_ops'

107+ let rowOps'' = swapSkipsForSingleColumnCharSpan ' ' currentAttr rowOps'

108− MVector.write ops row row_ops''

108+ MVector.write ops row rowOps''

109 return ops

110−substitute_skips (Background {background_char, background_attr}) ops = do

110+substituteSkips (Background {backgroundChar, backgroundAttr}) ops = do

111 -- At this point we decide if the background character is single column or not.

112 -- obviously, single column is easier.

113− case safe_wcwidth background_char of

113+ case safeWcwidth backgroundChar of

114− w | w == 0 -> fail $ "invalid background character " ++ show background_char

114+ w | w == 0 -> fail $ "invalid background character " ++ show backgroundChar

115 | w == 1 -> do

116 forM_ [0 .. MVector.length ops - 1] $ \row -> do

117− row_ops <- MVector.read ops row

117+ rowOps <- MVector.read ops row

118− let row_ops' = swap_skips_for_single_column_char_span background_char background_attr row_ops

118+ let rowOps' = swapSkipsForSingleColumnCharSpan backgroundChar backgroundAttr rowOps

119− MVector.write ops row row_ops'

119+ MVector.write ops row rowOps'

120 | otherwise -> do

121 forM_ [0 .. MVector.length ops - 1] $ \row -> do

122− row_ops <- MVector.read ops row

122+ rowOps <- MVector.read ops row

123− let row_ops' = swap_skips_for_char_span w background_char background_attr row_ops

123+ let rowOps' = swapSkipsForCharSpan w backgroundChar backgroundAttr rowOps

124− MVector.write ops row row_ops'

124+ MVector.write ops row rowOps'

125 return ops

126

127−merge_under :: MRowOps s -> MRowOps s -> ST s (MRowOps s)

127+mergeUnder :: MRowOps s -> MRowOps s -> ST s (MRowOps s)

128−merge_under upper lower = do

128+mergeUnder upper lower = do

129 forM_ [0 .. MVector.length upper - 1] $ \row -> do

130− upper_row_ops <- MVector.read upper row

130+ upperRowOps <- MVector.read upper row

131− lower_row_ops <- MVector.read lower row

131+ lowerRowOps <- MVector.read lower row

132− let row_ops = merge_row_under upper_row_ops lower_row_ops

132+ let rowOps = mergeRowUnder upperRowOps lowerRowOps

133− MVector.write upper row row_ops

133+ MVector.write upper row rowOps

134 return upper

135

136-- fugly

137−merge_row_under :: SpanOps -> SpanOps -> SpanOps

137+mergeRowUnder :: SpanOps -> SpanOps -> SpanOps

138−merge_row_under upper_row_ops lower_row_ops =

138+mergeRowUnder upperRowOps lowerRowOps =

139− on_upper_op Vector.empty (Vector.head upper_row_ops) (Vector.tail upper_row_ops) lower_row_ops

139+ onUpperOp Vector.empty (Vector.head upperRowOps) (Vector.tail upperRowOps) lowerRowOps

140 where

141 -- H: it will never be the case that we are out of upper ops before lower ops.

142− on_upper_op :: SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps

142+ onUpperOp :: SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps

143− on_upper_op out_ops op@(TextSpan _ w _ _) upper_ops lower_ops =

143+ onUpperOp outOps op@(TextSpan _ w _ _) upperOps lowerOps =

144− let lower_ops' = drop_ops w lower_ops

144+ let lowerOps' = dropOps w lowerOps

145− out_ops' = Vector.snoc out_ops op

145+ outOps' = Vector.snoc outOps op

146− in if Vector.null lower_ops'

146+ in if Vector.null lowerOps'

147− then out_ops'

147+ then outOps'

148− else on_upper_op out_ops' (Vector.head upper_ops) (Vector.tail upper_ops) lower_ops'

148+ else onUpperOp outOps' (Vector.head upperOps) (Vector.tail upperOps) lowerOps'

149− on_upper_op out_ops (Skip w) upper_ops lower_ops =

149+ onUpperOp outOps (Skip w) upperOps lowerOps =

150− let (ops', lower_ops') = split_ops_at w lower_ops

150+ let (ops', lowerOps') = splitOpsAt w lowerOps

151− out_ops' = out_ops `mappend` ops'

151+ outOps' = outOps `mappend` ops'

152− in if Vector.null lower_ops'

152+ in if Vector.null lowerOps'

153− then out_ops'

153+ then outOps'

154− else on_upper_op out_ops' (Vector.head upper_ops) (Vector.tail upper_ops) lower_ops'

154+ else onUpperOp outOps' (Vector.head upperOps) (Vector.tail upperOps) lowerOps'

155− on_upper_op _ (RowEnd _) _ _ = error "cannot merge rows containing RowEnd ops"

155+ onUpperOp _ (RowEnd _) _ _ = error "cannot merge rows containing RowEnd ops"

156

157

158−swap_skips_for_single_column_char_span :: Char -> Attr -> SpanOps -> SpanOps

158+swapSkipsForSingleColumnCharSpan :: Char -> Attr -> SpanOps -> SpanOps

159−swap_skips_for_single_column_char_span c a = Vector.map f

159+swapSkipsForSingleColumnCharSpan c a = Vector.map f

160 where f (Skip ow) = let txt = TL.pack $ replicate ow c

161 in TextSpan a ow ow txt

162 f v = v

163

164−swap_skips_for_char_span :: Int -> Char -> Attr -> SpanOps -> SpanOps

164+swapSkipsForCharSpan :: Int -> Char -> Attr -> SpanOps -> SpanOps

165−swap_skips_for_char_span w c a = Vector.map f

165+swapSkipsForCharSpan w c a = Vector.map f

166 where

167 f (Skip ow) = let txt_0_cw = ow `div` w

168 txt_0 = TL.pack $ replicate txt_0_cw c

@@ -178,10 +178,10 @@ swap_skips_for_char_span w c a = Vector.map f

178-- Crops to the given display region.

179--

180-- \todo I'm pretty sure there is an algorithm that does not require a mutable buffer.

181−build_spans :: Image -> DisplayRegion -> ST s (MRowOps s)

181+buildSpans :: Image -> DisplayRegion -> ST s (MRowOps s)

182−build_spans image out_region = do

182+buildSpans image outRegion = do

183 -- First we create a mutable vector for each rows output operations.

184− out_ops <- MVector.replicate (region_height out_region) Vector.empty

184+ outOps <- MVector.replicate (regionHeight outRegion) Vector.empty

185 -- \todo I think building the span operations in display order would provide better performance.

186 -- However, I got stuck trying to implement an algorithm that did this. This will be considered

187 -- as a possible future optimization.

@@ -193,33 +193,33 @@ build_spans image out_region = do

193 --

194 -- The images are made into span operations from left to right. It's possible that this could

195 -- easily be made to assure top to bottom output as well.

196− when (region_height out_region > 0 && region_width out_region > 0) $ do

196+ when (regionHeight outRegion > 0 && regionWidth outRegion > 0) $ do

197 -- The ops builder recursively descends the image and outputs span ops that would

198 -- display that image. The number of columns remaining in this row before exceeding the

199 -- bounds is also provided. This is used to clip the span ops produced to the display.

200− let full_build = do

200+ let fullBuild = do

201− start_image_build image

201+ startImageBuild image

202 -- Fill in any unspecified columns with a skip.

203− forM_ [0 .. (region_height out_region - 1)] (add_row_completion out_region)

203+ forM_ [0 .. (regionHeight outRegion - 1)] (addRowCompletion outRegion)

204− init_env = BlitEnv out_region out_ops

204+ initEnv = BlitEnv outRegion outOps

205− init_state = BlitState 0 0 0 0 (region_width out_region) (region_height out_region)

205+ initState = BlitState 0 0 0 0 (regionWidth outRegion) (regionHeight outRegion)

206− _ <- runStateT (runReaderT full_build init_env) init_state

206+ _ <- runStateT (runReaderT fullBuild initEnv) initState

207 return ()

208− return out_ops

208+ return outOps

209

210-- | Add the operations required to build a given image to the current set of row operations

211-- returns the number of columns and rows contributed to the output.

212−start_image_build :: Image -> BlitM s ()

212+startImageBuild :: Image -> BlitM s ()

213−start_image_build image = do

213+startImageBuild image = do

214− out_of_bounds <- is_out_of_bounds image <$> get

214+ outOfBounds <- isOutOfBounds image <$> get

215− when (not out_of_bounds) $ add_maybe_clipped image

215+ when (not outOfBounds) $ addMaybeClipped image

216

217−is_out_of_bounds :: Image -> BlitState -> Bool

217+isOutOfBounds :: Image -> BlitState -> Bool

218−is_out_of_bounds i s

218+isOutOfBounds i s

219− | s ^. remaining_columns <= 0 = True

219+ | s ^. remainingColumns <= 0 = True

220− | s ^. remaining_rows <= 0 = True

220+ | s ^. remainingRows <= 0 = True

221− | s ^. skip_columns >= image_width i = True

221+ | s ^. skipColumns >= imageWidth i = True

222− | s ^. skip_rows >= image_height i = True

222+ | s ^. skipRows >= imageHeight i = True

223 | otherwise = False

224

225-- | This adds an image that might be partially clipped to the output ops.

@@ -229,58 +229,58 @@ is_out_of_bounds i s

229-- this.

230--

231-- \todo prove this cannot be called in an out of bounds case.

232−add_maybe_clipped :: forall s . Image -> BlitM s ()

232+addMaybeClipped :: forall s . Image -> BlitM s ()

233−add_maybe_clipped EmptyImage = return ()

233+addMaybeClipped EmptyImage = return ()

234−add_maybe_clipped (HorizText a text_str ow _cw) = do

234+addMaybeClipped (HorizText a textStr ow _cw) = do

235 -- TODO: assumption that text spans are only 1 row high.

236− s <- use skip_rows

236+ s <- use skipRows

237 when (s < 1) $ do

238− left_clip <- use skip_columns

238+ leftClip <- use skipColumns

239− right_clip <- use remaining_columns

239+ rightClip <- use remainingColumns

240− let left_clipped = left_clip > 0

240+ let leftClipped = leftClip > 0

241− right_clipped = (ow - left_clip) > right_clip

241+ rightClipped = (ow - leftClip) > rightClip

242− if left_clipped || right_clipped

242+ if leftClipped || rightClipped

243− then let text_str' = clip_text text_str left_clip right_clip

243+ then let textStr' = clipText textStr leftClip rightClip

244− in add_unclipped_text a text_str'

244+ in addUnclippedText a textStr'

245− else add_unclipped_text a text_str

245+ else addUnclippedText a textStr

246−add_maybe_clipped (VertJoin top_image bottom_image _ow oh) = do

246+addMaybeClipped (VertJoin topImage bottomImage _ow oh) = do

247− add_maybe_clipped_join "vert_join" skip_rows remaining_rows row_offset

247+ addMaybeClippedJoin "vert_join" skipRows remainingRows rowOffset

248− (image_height top_image)

248+ (imageHeight topImage)

249− top_image

249+ topImage

250− bottom_image

250+ bottomImage

251 oh

252−add_maybe_clipped (HorizJoin left_image right_image ow _oh) = do

252+addMaybeClipped (HorizJoin leftImage rightImage ow _oh) = do

253− add_maybe_clipped_join "horiz_join" skip_columns remaining_columns column_offset

253+ addMaybeClippedJoin "horiz_join" skipColumns remainingColumns columnOffset

254− (image_width left_image)

254+ (imageWidth leftImage)

255− left_image

255+ leftImage

256− right_image

256+ rightImage

257 ow

258−add_maybe_clipped BGFill {output_width, output_height} = do

258+addMaybeClipped BGFill {outputWidth, outputHeight} = do

259 s <- get

260− let output_width' = min (output_width - s^.skip_columns) (s^.remaining_columns)

260+ let outputWidth' = min (outputWidth - s^.skipColumns) (s^.remainingColumns)

261− output_height' = min (output_height - s^.skip_rows ) (s^.remaining_rows)

261+ outputHeight' = min (outputHeight - s^.skipRows ) (s^.remainingRows)

262− y <- use row_offset

262+ y <- use rowOffset

263− forM_ [y..y+output_height'-1] $ snoc_op (Skip output_width')

263+ forM_ [y..y+outputHeight'-1] $ snocOp (Skip outputWidth')

264−add_maybe_clipped CropRight {cropped_image, output_width} = do

264+addMaybeClipped CropRight {croppedImage, outputWidth} = do

265− s <- use skip_columns

265+ s <- use skipColumns

266− r <- use remaining_columns

266+ r <- use remainingColumns

267− let x = output_width - s

267+ let x = outputWidth - s

268− when (x < r) $ remaining_columns .= x

268+ when (x < r) $ remainingColumns .= x

269− add_maybe_clipped cropped_image

269+ addMaybeClipped croppedImage

270−add_maybe_clipped CropLeft {cropped_image, left_skip} = do

270+addMaybeClipped CropLeft {croppedImage, leftSkip} = do

271− skip_columns += left_skip

271+ skipColumns += leftSkip

272− add_maybe_clipped cropped_image

272+ addMaybeClipped croppedImage

273−add_maybe_clipped CropBottom {cropped_image, output_height} = do

273+addMaybeClipped CropBottom {croppedImage, outputHeight} = do

274− s <- use skip_rows

274+ s <- use skipRows

275− r <- use remaining_rows

275+ r <- use remainingRows

276− let x = output_height - s

276+ let x = outputHeight - s

277− when (x < r) $ remaining_rows .= x

277+ when (x < r) $ remainingRows .= x

278− add_maybe_clipped cropped_image

278+ addMaybeClipped croppedImage

279−add_maybe_clipped CropTop {cropped_image, top_skip} = do

279+addMaybeClipped CropTop {croppedImage, topSkip} = do

280− skip_rows += top_skip

280+ skipRows += topSkip

281− add_maybe_clipped cropped_image

281+ addMaybeClipped croppedImage

282

283−add_maybe_clipped_join :: forall s . String

283+addMaybeClippedJoin :: forall s . String

284 -> Lens BlitState BlitState Int Int

285 -> Lens BlitState BlitState Int Int

286 -> Lens BlitState BlitState Int Int

@@ -289,7 +289,7 @@ add_maybe_clipped_join :: forall s . String

289 -> Image

290 -> Int

291 -> BlitM s ()

292−add_maybe_clipped_join name skip remaining offset i0_dim i0 i1 size = do

292+addMaybeClippedJoin name skip remaining offset i0_dim i0 i1 size = do

293 state <- get

294 when (state^.remaining <= 0) $ fail $ name ++ " with remaining <= 0"

295 case state^.skip of

@@ -297,48 +297,48 @@ add_maybe_clipped_join name skip remaining offset i0_dim i0 i1 size = do

297 | s >= size -> fail $ name ++ " on fully clipped"

298 | s == 0 -> if state^.remaining > i0_dim

299 then do

300− add_maybe_clipped i0

300+ addMaybeClipped i0

301 put $ state & offset +~ i0_dim & remaining -~ i0_dim

302− add_maybe_clipped i1

302+ addMaybeClipped i1

303− else add_maybe_clipped i0

303+ else addMaybeClipped i0

304 | s < i0_dim ->

305 let i0_dim' = i0_dim - s

306 in if state^.remaining <= i0_dim'

307− then add_maybe_clipped i0

307+ then addMaybeClipped i0

308 else do

309− add_maybe_clipped i0

309+ addMaybeClipped i0

310 put $ state & offset +~ i0_dim' & remaining -~ i0_dim' & skip .~ 0

311− add_maybe_clipped i1

311+ addMaybeClipped i1

312 | s >= i0_dim -> do

313 put $ state & skip -~ i0_dim

314− add_maybe_clipped i1

314+ addMaybeClipped i1

315 _ -> fail $ name ++ " has unhandled skip class"

316

317−add_unclipped_text :: Attr -> DisplayText -> BlitM s ()

317+addUnclippedText :: Attr -> DisplayText -> BlitM s ()

318−add_unclipped_text a txt = do

318+addUnclippedText a txt = do

319− let op = TextSpan a used_display_columns

319+ let op = TextSpan a usedDisplayColumns

320 (fromIntegral $ TL.length txt)

321 txt

322− used_display_columns = wcswidth $ TL.unpack txt

322+ usedDisplayColumns = wcswidth $ TL.unpack txt

323− use row_offset >>= snoc_op op

323+ use rowOffset >>= snocOp op

324

325−add_row_completion :: DisplayRegion -> Int -> BlitM s ()

325+addRowCompletion :: DisplayRegion -> Int -> BlitM s ()

326−add_row_completion display_region row = do

326+addRowCompletion displayRegion row = do

327− all_row_ops <- view mrow_ops

327+ allRowOps <- view mrowOps

328− row_ops <- lift $ lift $ MVector.read all_row_ops row

328+ rowOps <- lift $ lift $ MVector.read allRowOps row

329− let end_x = span_ops_effected_columns row_ops

329+ let end_x = spanOpsEffectedColumns rowOps

330− when (end_x < region_width display_region) $ do

330+ when (end_x < regionWidth displayRegion) $ do

331− let ow = region_width display_region - end_x

331+ let ow = regionWidth displayRegion - end_x

332− snoc_op (Skip ow) row

332+ snocOp (Skip ow) row

333

334-- | snocs the operation to the operations for the given row.

335−snoc_op :: SpanOp -> Int -> BlitM s ()

335+snocOp :: SpanOp -> Int -> BlitM s ()

336−snoc_op !op !row = do

336+snocOp !op !row = do

337− the_mrow_ops <- view mrow_ops

337+ theMrowOps <- view mrowOps

338− the_region <- view region

338+ theRegion <- view region

339 lift $ lift $ do

340− ops <- MVector.read the_mrow_ops row

340+ ops <- MVector.read theMrowOps row

341 let ops' = Vector.snoc ops op

342− when (span_ops_effected_columns ops' > region_width the_region)

342+ when (spanOpsEffectedColumns ops' > regionWidth theRegion)

343 $ fail $ "row " ++ show row ++ " now exceeds region width"

344− MVector.write the_mrow_ops row ops'

344+ MVector.write theMrowOps row ops'

src/Graphics/Vty/Prelude.hs+4−4

@@ -11,8 +11,8 @@ import Control.Monad

11-- | Named alias for a Int pair

12type DisplayRegion = (Int,Int)

14−region_width :: DisplayRegion -> Int

14+regionWidth :: DisplayRegion -> Int

15−region_width = fst

15+regionWidth = fst

17−region_height :: DisplayRegion -> Int

17+regionHeight :: DisplayRegion -> Int

18−region_height = snd

18+regionHeight = snd

src/Graphics/Vty/Span.hs+50−50

@@ -8,7 +8,7 @@

8 - nth row (from top to bottom) of the picture to render.

9 -

10 - A span op sequence will be defined for all rows and columns (and no more) of the region provided

11− - with the picture to spans_for_pic.

11+ - with the picture to `spansForPic`.

12 -

13 - todo: Partition attribute changes into multiple categories according to the serialized

14 - representation of the various attributes.

@@ -19,7 +19,7 @@ module Graphics.Vty.Span

19import Graphics.Vty.Prelude

21import Graphics.Vty.Image

22−import Graphics.Vty.Image.Internal ( clip_text )

22+import Graphics.Vty.Image.Internal ( clipText )

24import qualified Data.Text.Lazy as TL

25import Data.Vector (Vector)

@@ -32,10 +32,10 @@ data SpanOp =

32 -- character does not necessarially represent 1 colunm. See Codec.Binary.UTF8.Width

33 -- TextSpan [Attr] [output width in columns] [number of characters] [data]

34 TextSpan

35− { text_span_attr :: !Attr

35+ { textSpanAttr :: !Attr

36− , text_span_output_width :: !Int

36+ , textSpanOutputWidth :: !Int

37− , text_span_char_width :: !Int

37+ , textSpanCharWidth :: !Int

38− , text_span_text :: DisplayText

38+ , textSpanText :: DisplayText

39 }

40 -- | Skips the given number of columns

41 -- A skip is transparent.... maybe? I am not sure how attribute changes interact.

@@ -54,39 +54,39 @@ data SpanOp =

54-- color is changed.

55type SpanOps = Vector SpanOp

57−drop_ops :: Int -> SpanOps -> SpanOps

57+dropOps :: Int -> SpanOps -> SpanOps

58−drop_ops w = snd . split_ops_at w

58+dropOps w = snd . splitOpsAt w

60−split_ops_at :: Int -> SpanOps -> (SpanOps, SpanOps)

60+splitOpsAt :: Int -> SpanOps -> (SpanOps, SpanOps)

61−split_ops_at in_w in_ops = split_ops_at' in_w in_ops

61+splitOpsAt in_w in_ops = splitOpsAt' in_w in_ops

62 where

63− split_ops_at' 0 ops = (Vector.empty, ops)

63+ splitOpsAt' 0 ops = (Vector.empty, ops)

64− split_ops_at' remaining_columns ops = case Vector.head ops of

64+ splitOpsAt' remainingColumns ops = case Vector.head ops of

65− t@(TextSpan {}) -> if remaining_columns >= text_span_output_width t

65+ t@(TextSpan {}) -> if remainingColumns >= textSpanOutputWidth t

66− then let (pre,post) = split_ops_at' (remaining_columns - text_span_output_width t)

66+ then let (pre,post) = splitOpsAt' (remainingColumns - textSpanOutputWidth t)

67− (Vector.tail ops)

67+ (Vector.tail ops)

68 in (Vector.cons t pre, post)

69− else let pre_txt = clip_text (text_span_text t) 0 remaining_columns

69+ else let pre_txt = clipText (textSpanText t) 0 remainingColumns

70− pre_op = TextSpan { text_span_attr = text_span_attr t

70+ pre_op = TextSpan { textSpanAttr = textSpanAttr t

71− , text_span_output_width = remaining_columns

71+ , textSpanOutputWidth = remainingColumns

72− , text_span_char_width = fromIntegral $! TL.length pre_txt

72+ , textSpanCharWidth = fromIntegral $! TL.length pre_txt

73− , text_span_text = pre_txt

73+ , textSpanText = pre_txt

74 }

75− post_width = text_span_output_width t - remaining_columns

75+ post_width = textSpanOutputWidth t - remainingColumns

76− post_txt = clip_text (text_span_text t) remaining_columns post_width

76+ post_txt = clipText (textSpanText t) remainingColumns post_width

77− post_op = TextSpan { text_span_attr = text_span_attr t

77+ post_op = TextSpan { textSpanAttr = textSpanAttr t

78− , text_span_output_width = post_width

78+ , textSpanOutputWidth = post_width

79− , text_span_char_width = fromIntegral $! TL.length post_txt

79+ , textSpanCharWidth = fromIntegral $! TL.length post_txt

80− , text_span_text = post_txt

80+ , textSpanText = post_txt

81 }

82 in ( Vector.singleton pre_op

83 , Vector.cons post_op (Vector.tail ops)

84 )

85− Skip w -> if remaining_columns >= w

85+ Skip w -> if remainingColumns >= w

86− then let (pre,post) = split_ops_at' (remaining_columns - w) (Vector.tail ops)

86+ then let (pre,post) = splitOpsAt' (remainingColumns - w) (Vector.tail ops)

87 in (Vector.cons (Skip w) pre, post)

88− else ( Vector.singleton $ Skip remaining_columns

88+ else ( Vector.singleton $ Skip remainingColumns

89− , Vector.cons (Skip (w - remaining_columns)) (Vector.tail ops)

89+ , Vector.cons (Skip (w - remainingColumns)) (Vector.tail ops)

90 )

91 RowEnd _ -> error "cannot split ops containing a row end"

@@ -102,37 +102,37 @@ instance Show SpanOp where

102-- | Number of columns the DisplayOps are defined for

103--

104-- All spans are verified to define same number of columns. See: VerifySpanOps

105−display_ops_columns :: DisplayOps -> Int

105+displayOpsColumns :: DisplayOps -> Int

106−display_ops_columns ops

106+displayOpsColumns ops

107 | Vector.length ops == 0 = 0

108 | otherwise = Vector.length $ Vector.head ops

109

110-- | Number of rows the DisplayOps are defined for

111−display_ops_rows :: DisplayOps -> Int

111+displayOpsRows :: DisplayOps -> Int

112−display_ops_rows ops = Vector.length ops

112+displayOpsRows ops = Vector.length ops

113

114−effected_region :: DisplayOps -> DisplayRegion

114+effectedRegion :: DisplayOps -> DisplayRegion

115−effected_region ops = (display_ops_columns ops, display_ops_rows ops)

115+effectedRegion ops = (displayOpsColumns ops, displayOpsRows ops)

116

117-- | The number of columns a SpanOps effects.

118−span_ops_effected_columns :: SpanOps -> Int

118+spanOpsEffectedColumns :: SpanOps -> Int

119−span_ops_effected_columns in_ops = Vector.foldl' span_ops_effected_columns' 0 in_ops

119+spanOpsEffectedColumns in_ops = Vector.foldl' spanOpsEffectedColumns' 0 in_ops

120 where

121− span_ops_effected_columns' t (TextSpan _ w _ _ ) = t + w

121+ spanOpsEffectedColumns' t (TextSpan _ w _ _ ) = t + w

122− span_ops_effected_columns' t (Skip w) = t + w

122+ spanOpsEffectedColumns' t (Skip w) = t + w

123− span_ops_effected_columns' t (RowEnd w) = t + w

123+ spanOpsEffectedColumns' t (RowEnd w) = t + w

124

125-- | The width of a single SpanOp in columns

126−span_op_has_width :: SpanOp -> Maybe (Int, Int)

126+spanOpHasWidth :: SpanOp -> Maybe (Int, Int)

127−span_op_has_width (TextSpan _ ow cw _) = Just (cw, ow)

127+spanOpHasWidth (TextSpan _ ow cw _) = Just (cw, ow)

128−span_op_has_width (Skip ow) = Just (ow,ow)

128+spanOpHasWidth (Skip ow) = Just (ow,ow)

129−span_op_has_width (RowEnd ow) = Just (ow,ow)

129+spanOpHasWidth (RowEnd ow) = Just (ow,ow)

130

131-- | returns the number of columns to the character at the given position in the span op

132−columns_to_char_offset :: Int -> SpanOp -> Int

132+columnsToCharOffset :: Int -> SpanOp -> Int

133−columns_to_char_offset cx (TextSpan _ _ _ utf8_str) =

133+columnsToCharOffset cx (TextSpan _ _ _ utf8Str) =

134− let str = TL.unpack utf8_str

134+ let str = TL.unpack utf8Str

135 in wcswidth (take cx str)

136−columns_to_char_offset cx (Skip _) = cx

136+columnsToCharOffset cx (Skip _) = cx

137−columns_to_char_offset cx (RowEnd _) = cx

137+columnsToCharOffset cx (RowEnd _) = cx

138

test/BenchImageFuzz.hs+6−6

@@ -15,15 +15,15 @@ import System.Random

15rand :: Arbitrary a => IO a

16rand = head <$> sample' arbitrary

18−random_image :: IO Image

18+randomImage :: IO Image

19−random_image = rand

19+randomImage = rand

21−random_picture = pic_for_image <$> random_image

21+randomPicture = picForImage <$> randomImage

23−bench_0 = do

23+bench0 = do

24 vty <- mkVty def

25− (w,h) <- display_bounds $ output_iface vty

25+ (w,h) <- displayBounds $ outputIface vty

26− let pictures = replicateM 3000 random_picture

26+ let pictures = replicateM 3000 randomPicture

27 bench ps = do

28 forM ps (update vty)

29 shutdown vty

test/BenchNoDiffOpt.hs+16−16

@@ -16,24 +16,24 @@ import System.Environment( getArgs )

16import System.IO

17import System.Random

19−bench_0 = do

19+bench0 = do

20− let fixed_gen = mkStdGen 0

20+ let fixedGen = mkStdGen 0

21− setStdGen fixed_gen

21+ setStdGen fixedGen

22 vty <- mkVty def

23− (w,h) <- display_bounds $ output_iface vty

23+ (w,h) <- displayBounds $ outputIface vty

24− let images = return $ (image_0, image_1)

24+ let images = return $ (image0, image1)

25− image_0 = char_fill def_attr 'X' w h

25+ image0 = charFill defAttr 'X' w h

26− image_1 = char_fill def_attr '0' w h

26+ image1 = charFill defAttr '0' w h

27 bench d = do

28− flip_out vty 300 image_0 image_1

28+ flipOut vty 300 image0 image1

29 shutdown vty

30 return $ Bench images bench

32−flip_out vty n image_0 image_1 =

32+flipOut vty n image0 image1 =

33− let !p_left = pic_for_image image_0

33+ let !pLeft = picForImage image0

34− !p_right = pic_for_image image_1

34+ !pRight = picForImage image1

35− w_left 0 = return ()

35+ wLeft 0 = return ()

36− w_left n = update vty p_left >> w_right (n-1)

36+ wLeft n = update vty pLeft >> wRight (n-1)

37− w_right 0 = return ()

37+ wRight 0 = return ()

38− w_right n = update vty p_right >> w_left (n-1)

38+ wRight n = update vty pRight >> wLeft (n-1)

39− in w_left n

39+ in wLeft n

test/BenchRenderChar.hs+19−19

@@ -11,30 +11,30 @@ import Control.Monad ( forM_ )

12import Data.Default (def)

14−bench_0 = do

14+bench0 = do

15 vty <- mkVty def

16− (w,h) <- display_bounds $ output_iface vty

16+ (w,h) <- displayBounds $ outputIface vty

17− let test_chars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]

17+ let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]

18 bench d = do

19− forM_ d $ \test_char -> do

19+ forM_ d $ \testChar -> do

20− let test_image = test_image_using_char test_char w h

20+ let testImage = testImageUsingChar testChar w h

21− out_pic = pic_for_image test_image

21+ outPic = picForImage testImage

22− update vty out_pic

22+ update vty outPic

23 shutdown vty

24− return $ Bench test_chars bench

24+ return $ Bench testChars bench

26−test_image_using_char c w h

26+testImageUsingChar c w h

27− = vert_cat $ replicate (fromIntegral h)

27+ = vertCat $ replicate (fromIntegral h)

28− $ horiz_cat $ map (char def_attr) (replicate (fromIntegral w) c)

28+ $ horizCat $ map (char defAttr) (replicate (fromIntegral w) c)

30−bench_1 = do

30+bench1 = do

31 vty <- mkVty def

32− (w,h) <- display_bounds $ output_iface vty

32+ (w,h) <- displayBounds $ outputIface vty

33− let test_chars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]

33+ let testChars = return $ take 500 $ cycle $ [ c | c <- ['a'..'z']]

34 bench d = do

35− forM_ d $ \test_char -> do

35+ forM_ d $ \testChar -> do

36− let test_image = char_fill def_attr test_char w h

36+ let testImage = charFill defAttr testChar w h

37− out_pic = pic_for_image test_image

37+ outPic = picForImage testImage

38− update vty out_pic

38+ update vty outPic

39 shutdown vty

40− return $ Bench test_chars bench

40+ return $ Bench testChars bench

test/BenchVerticalScroll.hs+8−8

@@ -14,12 +14,12 @@ import System.Environment( getArgs )

14import System.IO

15import System.Random

17−bench_0 = do

17+bench0 = do

18− let fixed_gen = mkStdGen 0

18+ let fixedGen = mkStdGen 0

19− setStdGen fixed_gen

19+ setStdGen fixedGen

20 return $ Bench (return ()) (\() -> mkVty def >>= liftM2 (>>) run shutdown)

22−run vt = mapM_ (\p -> update vt p) . benchgen =<< display_bounds (output_iface vt)

22+run vt = mapM_ (\p -> update vt p) . benchgen =<< displayBounds (outputIface vt)

24-- Currently, we just do scrolling.

25takem :: (a -> Int) -> Int -> [a] -> ([a],[a])

@@ -41,21 +41,21 @@ lengths ml g =

41nums :: StdGen -> [(Attr, String)]

42nums g = let (x,g2) = (random g :: (Int, StdGen))

43 (c,g3) = random g2

44− in ( if c then def_attr `with_fore_color` red else def_attr

44+ in ( if c then defAttr `withForeColor` red else defAttr

45 , shows x " "

46 ) : nums g3

48pad :: Int -> Image -> Image

49−pad ml img = img <|> char_fill def_attr ' ' (ml - image_width img) 1

49+pad ml img = img <|> charFill defAttr ' ' (ml - imageWidth img) 1

51clines :: StdGen -> Int -> [Image]

52−clines g maxll = map (pad maxll . horiz_cat . map (uncurry string))

52+clines g maxll = map (pad maxll . horizCat . map (uncurry string))

53 $ fold (length . snd) (lengths maxll g1) (nums g2)

54 where (g1,g2) = split g

56benchgen :: DisplayRegion -> [Picture]

57benchgen (w,h)

58− = take 2000 $ map ((\i -> pic_for_image i) . vert_cat . take (fromEnum h))

58+ = take 2000 $ map ((\i -> picForImage i) . vertCat . take (fromEnum h))

59 $ tails

60 $ clines (mkStdGen 80) w

test/ControlTable.hs+3−3

@@ -6,9 +6,9 @@ import System.Console.Terminfo

7main = do

8 terminal <- setupTermFromEnv

9− control_table <- init_control_table terminal

9+ controlTable <- init_controlTable terminal

10 putStrLn $ "ANSI terminal show cursor string: " ++ show cvis

11− putStrLn $ "Current terminal show cursor string: " ++ show (show_cursor_str control_table)

11+ putStrLn $ "Current terminal show cursor string: " ++ show (showCursorStr controlTable)

12 putStrLn $ "ANSI terminal hide cursor string: " ++ show civis

13− putStrLn $ "Current terminal hide cursor string: " ++ show (hide_cursor_str control_table)

13+ putStrLn $ "Current terminal hide cursor string: " ++ show (hideCursorStr controlTable)

test/EventEcho.hs+14−14

@@ -11,31 +11,31 @@ import Data.Sequence (Seq, (<|) )

11import qualified Data.Sequence as Seq

12import Data.Foldable

14−event_buffer_size = 1000

14+eventBufferSize = 1000

16type App = RWST Vty () (Seq String) IO

18main = do

19 vty <- mkVty def

20− _ <- execRWST (vty_interact False) vty Seq.empty

20+ _ <- execRWST (vtyInteract False) vty Seq.empty

21 shutdown vty

23−vty_interact :: Bool -> App ()

23+vtyInteract :: Bool -> App ()

24−vty_interact should_exit = do

24+vtyInteract shouldExit = do

25− update_display

25+ updateDisplay

26− unless should_exit $ handle_next_event >>= vty_interact

26+ unless shouldExit $ handleNextEvent >>= vtyInteract

28−update_display :: App ()

28+updateDisplay :: App ()

29−update_display = do

29+updateDisplay = do

30− let info = string def_attr "Press ESC to exit."

30+ let info = string defAttr "Press ESC to exit."

31− event_log <- foldMap (string def_attr) <$> get

31+ eventLog <- foldMap (string defAttr) <$> get

32− let pic = pic_for_image $ info <-> event_log

32+ let pic = picForImage $ info <-> eventLog

33 vty <- ask

34 liftIO $ update vty pic

36−handle_next_event = ask >>= liftIO . next_event >>= handle_event

36+handleNextEvent = ask >>= liftIO . nextEvent >>= handleEvent

37 where

38− handle_event e = do

38+ handleEvent e = do

39− modify $ (<|) (show e) >>> Seq.take event_buffer_size

39+ modify $ (<|) (show e) >>> Seq.take eventBufferSize

40 return $ e == EvKey KEsc []

test/Rouge.hs+52−52

@@ -18,8 +18,8 @@ import System.IO

18import System.Random

20data Dude = Dude

21− { dude_x :: Int

21+ { dudeX :: Int

22− , dude_y :: Int

22+ , dudeY :: Int

23 } deriving (Show,Eq)

25data World = World

@@ -34,7 +34,7 @@ data Level = Level

34 , geo :: Array (Int, Int) LevelPiece

35 -- building the geo image is expensive. Cache it. Though VTY should go through greater lengths

36 -- to avoid the need to cache images.

37− , geo_image :: Image

37+ , geoImage :: Image

38 }

39 deriving (Show,Eq)

@@ -47,62 +47,62 @@ type Game = RWST Vty () World IO

48main = do

49 vty <- mkVty def

50− level_0 <- mkLevel 1

50+ level0 <- mkLevel 1

51− let world_0 = World (Dude (fst $ start level_0) (snd $ start level_0)) level_0

51+ let world0 = World (Dude (fst $ start level0) (snd $ start level0)) level0

52− (_final_world, ()) <- execRWST (play >> update_display) vty world_0

52+ (_finalWorld, ()) <- execRWST (play >> updateDisplay) vty world0

53 shutdown vty

55mkLevel difficulty = do

56 let size = 80 * difficulty

57− [level_width, level_height] <- replicateM 2 $ randomRIO (size,size)

57+ [levelWidth, levelHeight] <- replicateM 2 $ randomRIO (size,size)

58− let randomP = (,) <$> randomRIO (2, level_width-3) <*> randomRIO (2, level_height-3)

58+ let randomP = (,) <$> randomRIO (2, levelWidth-3) <*> randomRIO (2, levelHeight-3)

59 start <- randomP

60 end <- randomP

61 -- first the base geography: all rocks

62− let base_geo = array ((0,0), (level_width, level_height))

62+ let baseGeo = array ((0,0), (levelWidth, levelHeight))

63− [((x,y),Rock) | x <- [0..level_width-1], y <- [0..level_height-1]]

63+ [((x,y),Rock) | x <- [0..levelWidth-1], y <- [0..levelHeight-1]]

64 -- next the empty spaces that make the rooms

65 -- for this we generate a number of center points

66 centers <- replicateM (2 ^ difficulty + difficulty) randomP

67 -- generate rooms for all those points, plus the start and end

68− geo <- foldM (add_room level_width level_height) base_geo (start : end : centers)

68+ geo <- foldM (addRoom levelWidth levelHeight) baseGeo (start : end : centers)

69− return $ Level start end geo (build_geo_image geo)

69+ return $ Level start end geo (buildGeoImage geo)

71−add_room level_width level_height geo (center_x, center_y) = do

71+addRoom levelWidth levelHeight geo (centerX, centerY) = do

72 size <- randomRIO (5,15)

73− let x_min = max 1 (center_x - size)

73+ let xMin = max 1 (centerX - size)

74− x_max = min (level_width - 1) (center_x + size)

74+ xMax = min (levelWidth - 1) (centerX + size)

75− y_min = max 1 (center_y - size)

75+ yMin = max 1 (centerY - size)

76− y_max = min (level_height - 1) (center_y + size)

76+ yMax = min (levelHeight - 1) (centerY + size)

77− let room = [((x,y), EmptySpace) | x <- [x_min..x_max - 1], y <- [y_min..y_max - 1]]

77+ let room = [((x,y), EmptySpace) | x <- [xMin..xMax - 1], y <- [yMin..yMax - 1]]

78 return (geo // room)

80−image_for_geo EmptySpace = char (def_attr `with_back_color` green) ' '

80+imageForGeo EmptySpace = char (defAttr `withBackColor` green) ' '

81−image_for_geo Rock = char def_attr 'X'

81+imageForGeo Rock = char defAttr 'X'

83−pieceA = def_attr `with_fore_color` blue `with_back_color` green

83+pieceA = defAttr `withForeColor` blue `withBackColor` green

84−dumpA = def_attr `with_style` reverse_video

84+dumpA = defAttr `withStyle` reverseVideo

86play = do

87− update_display

87+ updateDisplay

88− done <- process_event

88+ done <- processEvent

89 unless done play

91−process_event = do

91+processEvent = do

92− k <- ask >>= liftIO . next_event

92+ k <- ask >>= liftIO . nextEvent

93 if k == EvKey KEsc []

94 then return True

95 else do

96 case k of

97 EvKey (KChar 'r') [MCtrl] -> ask >>= liftIO . refresh

98− EvKey KLeft [] -> move_dude (-1) 0

98+ EvKey KLeft [] -> moveDude (-1) 0

99− EvKey KRight [] -> move_dude 1 0

99+ EvKey KRight [] -> moveDude 1 0

100− EvKey KUp [] -> move_dude 0 (-1)

100+ EvKey KUp [] -> moveDude 0 (-1)

101− EvKey KDown [] -> move_dude 0 1

101+ EvKey KDown [] -> moveDude 0 1

102 _ -> return ()

103 return False

104

105−move_dude dx dy = do

105+moveDude dx dy = do

106 vty <- ask

107 world <- get

108 let Dude x y = dude world

@@ -113,35 +113,35 @@ move_dude dx dy = do

113 EmptySpace -> put $ world { dude = Dude x' y' }

114 _ -> return ()

115

116−update_display :: Game ()

116+updateDisplay :: Game ()

117−update_display = do

117+updateDisplay = do

118− let info = string def_attr "Move with the arrows keys. Press ESC to exit."

118+ let info = string defAttr "Move with the arrows keys. Press ESC to exit."

119 -- determine offsets to place the dude in the center of the level.

120− (w,h) <- asks output_iface >>= liftIO . display_bounds

120+ (w,h) <- asks outputIface >>= liftIO . displayBounds

121− the_dude <- gets dude

121+ theDude <- gets dude

122− let ox = (w `div` 2) - dude_x the_dude

122+ let ox = (w `div` 2) - dudeX theDude

123− oy = (h `div` 2) - dude_y the_dude

123+ oy = (h `div` 2) - dudeY theDude

124 -- translate the world images to place the dude in the center of the level.

125 world' <- map (translate ox oy) <$> world

126− let pic = pic_for_layers $ info : world'

126+ let pic = picForLayers $ info : world'

127 vty <- ask

128 liftIO $ update vty pic

129

130world :: Game [Image]

131world = do

132− the_dude <- gets dude

132+ theDude <- gets dude

133− the_level <- gets level

133+ theLevel <- gets level

134− let dude_image = translate (dude_x the_dude) (dude_y the_dude) (char pieceA '@')

134+ let dudeImage = translate (dudeX theDude) (dudeY theDude) (char pieceA '@')

135− return [dude_image, geo_image the_level]

135+ return [dudeImage, geoImage theLevel]

136

137−build_geo_image geo =

137+buildGeoImage geo =

138− let (geo_width, geo_height) = snd $ bounds geo

138+ let (geoWidth, geoHeight) = snd $ bounds geo

139 -- seems like a the repeated index operation should be removable. This is not performing random

140 -- access but (presumably) access in order of index.

141− in vert_cat [ geo_row

141+ in vertCat [ geoRow

142− | y <- [0..geo_height-1]

142+ | y <- [0..geoHeight-1]

143− , let geo_row = horiz_cat [ i

143+ , let geoRow = horizCat [ i

144− | x <- [0..geo_width-1]

144+ | x <- [0..geoWidth-1]

145− , let i = image_for_geo (geo ! (x,y))

145+ , let i = imageForGeo (geo ! (x,y))

146− ]

146+ ]

147− ]

147+ ]

test/RougeStory.hs+73−73

@@ -33,20 +33,20 @@ class Story repr where

34 -- A quest is for a goal where some aspects are known and others unknown.

35 -- TODO: abstract to any Foldable?

36− empty_aspects :: repr Aspects

36+ emptyAspects :: repr Aspects

37− add_known_history :: repr History -> repr Aspects -> repr Aspects

37+ addKnownHistory :: repr History -> repr Aspects -> repr Aspects

38− add_known_obj :: repr Object -> repr Aspects -> repr Aspects

38+ addKnownObj :: repr Object -> repr Aspects -> repr Aspects

39− add_unknown_history :: repr History -> repr Aspects -> repr Aspects

39+ addUnknownHistory :: repr History -> repr Aspects -> repr Aspects

40− add_unknown_obj :: repr Object -> repr Aspects -> repr Aspects

40+ addUnknownObj :: repr Object -> repr Aspects -> repr Aspects

42 -- Aspects are animate objects, inanimate objects or histories.

43− animate_obj :: Type -> repr Object

43+ animateObj :: Type -> repr Object

44− inanimate_obj :: Type -> repr Object

44+ inanimateObj :: Type -> repr Object

45 history :: repr History

47 -- The goal is to acquire, or dispose of an object.

48− dispose_obj :: repr Object -> repr Goal

48+ disposeObj :: repr Object -> repr Goal

49− acquire_obj :: repr Object -> repr Goal

49+ acquireObj :: repr Object -> repr Goal

51 -- What is an object? Well, that's anything that fits in the story language.

52 -- Which at least means it's something that can be named

@@ -58,26 +58,26 @@ data Goal

58data Aspects

59data Object

61−story_0 =

61+story0 =

62− let bob = animate_obj "Human" `named` "Bob"

62+ let bob = animateObj "Human" `named` "Bob"

63− the_quest = quest (dispose_obj (inanimate_obj "YoYo" `named` "The Kitten Slayer"))

63+ theQuest = quest (disposeObj (inanimateObj "YoYo" `named` "The Kitten Slayer"))

64− (add_known_obj bob empty_aspects)

64+ (addKnownObj bob emptyAspects)

65− in story "Bob" the_quest

65+ in story "Bob" theQuest

67{- TEMPLATE

68instance Story X where

69 story c q =

70 quest g as =

71− empty_aspects =

71+ emptyAspects =

72− add_known_history h as =

72+ addKnownHistory h as =

73− add_known_obj obj as =

73+ addKnownObj obj as =

74− add_unknown_history h as =

74+ addUnknownHistory h as =

75− add_unknown_obj obj as =

75+ addUnknownObj obj as =

76− animate_obj t =

76+ animateObj t =

77− inanimate_obj t =

77+ inanimateObj t =

78 history =

79− dispose_obj obj =

79+ disposeObj obj =

80− acquire_obj obj =

80+ acquireObj obj =

81 named obj n =

82-}

@@ -85,16 +85,16 @@ newtype ShowStory t = ShowStory { unShowStory :: String }

85instance Story ShowStory where

86 story c q = ShowStory $ printf "History(%s,%s)" c (unShowStory q)

87 quest g as = ShowStory $ printf "Quest(%s,%s)" (unShowStory g) (unShowStory as)

88− empty_aspects = ShowStory $ printf "EmptyAspects"

88+ emptyAspects = ShowStory $ printf "EmptyAspects"

89− add_known_history h as = ShowStory $ printf "Known(%s):%s" (unShowStory h) (unShowStory as)

89+ addKnownHistory h as = ShowStory $ printf "Known(%s):%s" (unShowStory h) (unShowStory as)

90− add_known_obj obj as = ShowStory $ printf "Known(%s):%s" (unShowStory obj) (unShowStory as)

90+ addKnownObj obj as = ShowStory $ printf "Known(%s):%s" (unShowStory obj) (unShowStory as)

91− add_unknown_history h as = ShowStory $ printf "Unknown(%s):%s" (unShowStory h) (unShowStory as)

91+ addUnknownHistory h as = ShowStory $ printf "Unknown(%s):%s" (unShowStory h) (unShowStory as)

92− add_unknown_obj obj as = ShowStory $ printf "Unknown(%s):%s" (unShowStory obj) (unShowStory as)

92+ addUnknownObj obj as = ShowStory $ printf "Unknown(%s):%s" (unShowStory obj) (unShowStory as)

93− animate_obj t = ShowStory $ printf "%s :: AnimateObj" t

93+ animateObj t = ShowStory $ printf "%s :: AnimateObj" t

94− inanimate_obj t = ShowStory $ printf "%s :: InanimateObj" t

94+ inanimateObj t = ShowStory $ printf "%s :: InanimateObj" t

95 history = ShowStory $ printf "History"

96− dispose_obj obj = ShowStory $ printf "Goal(%s)" (unShowStory obj)

96+ disposeObj obj = ShowStory $ printf "Goal(%s)" (unShowStory obj)

97− acquire_obj obj = ShowStory $ printf "Acquire(%s)" (unShowStory obj)

97+ acquireObj obj = ShowStory $ printf "Acquire(%s)" (unShowStory obj)

98 named obj n = ShowStory $ printf "%s+Name(%s)" (unShowStory obj) (show n)

100newtype TellStory t = TellStory { unTellStory :: String }

@@ -104,80 +104,80 @@ instance Story TellStory where

104 quest (TellStory g) (TellStory as)

105 | as == "" = TellStory $ g ++ "."

106 | otherwise = TellStory $ g ++ ". In a world where... " ++ as

107− empty_aspects = TellStory ""

107+ emptyAspects = TellStory ""

108− add_known_history (TellStory h) (TellStory as)

108+ addKnownHistory (TellStory h) (TellStory as)

109 = TellStory $ "Our hero knows the tale of\n\t" ++ h ++ ".\n" ++ as

110− add_known_obj (TellStory obj) (TellStory as)

110+ addKnownObj (TellStory obj) (TellStory as)

111 = TellStory $ "Our hero knows of " ++ obj ++ ". " ++ as

112− add_unknown_history _ as = as

112+ addUnknownHistory _ as = as

113− add_unknown_obj _ as = as

113+ addUnknownObj _ as = as

114− animate_obj t = TellStory t

114+ animateObj t = TellStory t

115− inanimate_obj t = TellStory t

115+ inanimateObj t = TellStory t

116 history = TellStory "History"

117− dispose_obj (TellStory obj)

117+ disposeObj (TellStory obj)

118 = TellStory $ "to dispose of the accursed " ++ obj

119− acquire_obj (TellStory obj)

119+ acquireObj (TellStory obj)

120 = TellStory $ "to acquire the great " ++ obj

121 named (TellStory obj) name

122 = TellStory $ obj ++ " with the name " ++ name

123

124−newtype BuildSprites m t = BuildSprites {build_sprites :: StateT SpriteDB m ()}

124+newtype BuildSprites m t = BuildSprites {buildSprites :: StateT SpriteDB m ()}

125

126type Sprite = (Int, Int, Image)

127type Collider = (Int,Int,Int,Int)

128data SpriteDB = SpriteDB

129− { next_sprite_ID :: Int -- globally monotonic. H: Can fst . findMax + 1 be used?

129+ { nextSpriteID :: Int -- globally monotonic. H: Can fst . findMax + 1 be used?

130− , this_sprite_ID :: Int

130+ , thisSpriteID :: Int

131− , sprites :: Map Int Sprite

131+ , sprites :: Map Int Sprite

132 }

133 deriving (Show)

134

135−get_sprite_ID :: MonadIO m => StateT SpriteDB m Int

135+getSpriteID :: MonadIO m => StateT SpriteDB m Int

136−get_sprite_ID = gets this_sprite_ID

136+getSpriteID = gets thisSpriteID

137

138−new_sprite_ID :: MonadIO m => StateT SpriteDB m Int

138+newSpriteID :: MonadIO m => StateT SpriteDB m Int

139−new_sprite_ID = do

139+newSpriteID = do

140 ctx <- get

141− let the_ID = next_sprite_ID ctx

141+ let the_ID = nextSpriteID ctx

142− put $ ctx {next_sprite_ID = the_ID + 1, this_sprite_ID = the_ID}

142+ put $ ctx {nextSpriteID = the_ID + 1, thisSpriteID = the_ID}

143 return the_ID

144

145−empty_sprite_db = SpriteDB 0 1 Map.empty

145+emptySpriteDb = SpriteDB 0 1 Map.empty

146

147−add_sprite x y img i

147+addSprite x y img i

148 = modify (\ctx -> ctx {sprites = Map.insert i (x,y,img) (sprites ctx)})

149

150−add_random_sprite c i = do

150+addRandomSprite c i = do

151 let img = char def_attr c

152 [x,y] <- liftIO $ replicateM 2 $ randomRIO (-100,100)

153− add_sprite x y img i

153+ addSprite x y img i

154

155instance MonadIO m => Story (BuildSprites m) where

156 story _c (BuildSprites q) = BuildSprites q

157 quest (BuildSprites g) (BuildSprites as) = BuildSprites (g >> as)

158− empty_aspects = BuildSprites $ return ()

158+ emptyAspects = BuildSprites $ return ()

159− add_known_history h (BuildSprites as) = BuildSprites as

159+ addKnownHistory h (BuildSprites as) = BuildSprites as

160− add_known_obj obj (BuildSprites as) = BuildSprites as

160+ addKnownObj obj (BuildSprites as) = BuildSprites as

161− add_unknown_history h (BuildSprites as) = BuildSprites as

161+ addUnknownHistory h (BuildSprites as) = BuildSprites as

162− add_unknown_obj obj (BuildSprites as) = BuildSprites as

162+ addUnknownObj obj (BuildSprites as) = BuildSprites as

163− animate_obj _t = BuildSprites $ do

163+ animateObj _t = BuildSprites $ do

164− add_random_sprite '@' =<< new_sprite_ID

164+ addRandomSprite '@' =<< newSpriteID

165− inanimate_obj _t = BuildSprites $ do

165+ inanimateObj _t = BuildSprites $ do

166− add_random_sprite 'X' =<< new_sprite_ID

166+ addRandomSprite 'X' =<< newSpriteID

167 history = BuildSprites $ return ()

168− dispose_obj (BuildSprites obj) = BuildSprites obj

168+ disposeObj (BuildSprites obj) = BuildSprites obj

169− acquire_obj (BuildSprites obj) = BuildSprites obj

169+ acquireObj (BuildSprites obj) = BuildSprites obj

170 named (BuildSprites obj) n = BuildSprites obj

171

172−render_sprites = foldMap render_sprite . sprites

172+renderSprites = foldMap renderSprite . sprites

173−render_sprite (x,y,img) = return $ translate x y img

173+renderSprite (x,y,img) = return $ translate x y img

174

175main = do

176− putStrLn $ unTellStory story_0

176+ putStrLn $ unTellStory story0

177− putStrLn $ unShowStory story_0

177+ putStrLn $ unShowStory story0

178− sprite_db <- execStateT (build_sprites story_0) empty_sprite_db

178+ spriteDb <- execStateT (buildSprites story0) emptySpriteDb

179− print sprite_db

179+ print spriteDb

180− let imgs = render_sprites sprite_db

180+ let imgs = renderSprites spriteDb

181 p = pic_for_layers imgs

182 withVty $ flip update p

183 threadDelay 5000000

test/Verify.hs+4−4

@@ -50,11 +50,11 @@ import Control.Monad.State.Strict

50import Numeric ( showHex )

52verify :: Testable t => String -> t -> Test

53−verify test_name p = Test $ TestInstance

53+verify testName p = Test $ TestInstance

54− { name = test_name

54+ { name = testName

55 , run = do

56− qc_result <- quickCheckResult p

56+ qcResult <- quickCheckResult p

57− case qc_result of

57+ case qcResult of

58 QC.Success {..} -> return $ Finished TS.Pass

59 QC.Failure {numShrinks,reason} -> return $ Finished

60 $ TS.Fail $ "After "

test/Verify/Data/Terminfo/Parse.hs+30−30

@@ -12,8 +12,8 @@ import qualified Data.Vector.Unboxed as Vector

13import Numeric

15−hex_dump :: [Word8] -> String

15+hexDump :: [Word8] -> String

16−hex_dump bytes = foldr (\b s -> showHex b s) "" bytes

16+hexDump bytes = foldr (\b s -> showHex b s) "" bytes

18data NonParamCapString = NonParamCapString String

19 deriving Show

@@ -32,7 +32,7 @@ instance Arbitrary LiteralPercentCap where

32 arbitrary

33 = ( do

34 NonParamCapString s <- arbitrary

35− (s', bytes) <- insert_escape_op "%" [toEnum $ fromEnum '%'] s

35+ (s', bytes) <- insertEscapeOp "%" [toEnum $ fromEnum '%'] s

36 return $ LiteralPercentCap s' bytes

37 ) `suchThat` ( \(LiteralPercentCap str _) -> length str < 255 )

@@ -43,7 +43,7 @@ instance Arbitrary IncFirstTwoCap where

43 arbitrary

44 = ( do

45 NonParamCapString s <- arbitrary

46− (s', bytes) <- insert_escape_op "i" [] s

46+ (s', bytes) <- insertEscapeOp "i" [] s

47 return $ IncFirstTwoCap s' bytes

48 ) `suchThat` ( \(IncFirstTwoCap str _) -> length str < 255 )

@@ -55,7 +55,7 @@ instance Arbitrary PushParamCap where

55 = ( do

56 NonParamCapString s <- arbitrary

57 n <- choose (1,9)

58− (s', bytes) <- insert_escape_op ("p" ++ show n) [] s

58+ (s', bytes) <- insertEscapeOp ("p" ++ show n) [] s

59 return $ PushParamCap s' n bytes

60 ) `suchThat` ( \(PushParamCap str _ _) -> length str < 255 )

@@ -67,46 +67,46 @@ instance Arbitrary DecPrintCap where

67 = ( do

68 NonParamCapString s <- arbitrary

69 n <- choose (1,9)

70− (s', bytes) <- insert_escape_op ("p" ++ show n ++ "%d") [] s

70+ (s', bytes) <- insertEscapeOp ("p" ++ show n ++ "%d") [] s

71 return $ DecPrintCap s' n bytes

72 ) `suchThat` ( \(DecPrintCap str _ _) -> length str < 255 )

74−insert_escape_op op_str repl_bytes s = do

74+insertEscapeOp opStr replBytes s = do

75− insert_points <- listOf1 $ elements [0 .. length s - 1]

75+ insertPoints <- listOf1 $ elements [0 .. length s - 1]

76− let s' = f s ('%' : op_str)

76+ let s' = f s ('%' : opStr)

77− remaining_bytes = f (map (toEnum . fromEnum) s) repl_bytes

77+ remainingBytes = f (map (toEnum . fromEnum) s) replBytes

78 f in_vs out_v = concat [ vs

79 | vi <- zip in_vs [0 .. length s - 1]

80− , let vs = fst vi : ( if snd vi `elem` insert_points

80+ , let vs = fst vi : ( if snd vi `elem` insertPoints

81 then out_v

82 else []

83 )

84 ]

85− return (s', remaining_bytes)

85+ return (s', remainingBytes)

87−is_bytes_op :: CapOp -> Bool

87+isBytesOp :: CapOp -> Bool

88−is_bytes_op (Bytes {}) = True

88+isBytesOp (Bytes {}) = True

89−-- is_bytes_op _ = False

89+-- isBytesOp _ = False

91−bytes_for_range cap offset count

91+bytesForRange cap offset count

92− = Vector.toList $ Vector.take count $ Vector.drop offset $ cap_bytes cap

92+ = Vector.toList $ Vector.take count $ Vector.drop offset $ capBytes cap

94−collect_bytes :: CapExpression -> [Word8]

94+collectBytes :: CapExpression -> [Word8]

95−collect_bytes e = concat [ bytes

95+collectBytes e = concat [ bytes

96− | Bytes offset count <- cap_ops e

96+ | Bytes offset count <- capOps e

97− , let bytes = bytes_for_range e offset count

97+ , let bytes = bytesForRange e offset count

98− ]

98+ ]

100

101−verify_bytes_equal :: [Word8] -> [Word8] -> Result

101+verifyBytesEqual :: [Word8] -> [Word8] -> Result

102−verify_bytes_equal out_bytes expected_bytes

102+verifyBytesEqual outBytes expectedBytes

103− = if out_bytes == expected_bytes

103+ = if outBytes == expectedBytes

104 then succeeded

105 else failed

106− { reason = "out_bytes ["

106+ { reason = "outBytes ["

107− ++ hex_dump out_bytes

107+ ++ hexDump outBytes

108− ++ "] /= expected_bytes ["

108+ ++ "] /= expectedBytes ["

109− ++ hex_dump expected_bytes

109+ ++ hexDump expectedBytes

110− ++ "]"

110+ ++ "]"

111 }

112

test/Verify/Graphics/Vty/Attributes.hs+30−30

@@ -8,8 +8,8 @@ import Verify

9import Data.List ( delete )

11−all_colors :: [Color]

11+allColors :: [Color]

12−all_colors =

12+allColors =

13 [ black

14 , red

15 , green

@@ -18,56 +18,56 @@ all_colors =

18 , magenta

19 , cyan

20 , white

21− , bright_black

21+ , brightBlack

22− , bright_red

22+ , brightRed

23− , bright_green

23+ , brightGreen

24− , bright_yellow

24+ , brightYellow

25− , bright_blue

25+ , brightBlue

26− , bright_magenta

26+ , brightMagenta

27− , bright_cyan

27+ , brightCyan

28− , bright_white

28+ , brightWhite

29 ] ++ map Color240 [0..239]

31−all_styles :: [Style]

31+allStyles :: [Style]

32−all_styles =

32+allStyles =

33 [ standout

34 , underline

35− , reverse_video

35+ , reverseVideo

36 , blink

37 , dim

38 , bold

39 ]

41-- Limit the possible attributes to just a few for now.

42−possible_attr_mods :: [ AttrOp ]

42+possibleAttrMods :: [ AttrOp ]

43−possible_attr_mods =

43+possibleAttrMods =

44− [ id_op

44+ [ idOp

45− ] ++ map set_fore_color_op all_colors

45+ ] ++ map setForeColorOp allColors

46− ++ map set_back_color_op all_colors

46+ ++ map setBackColorOp allColors

47− ++ map set_style_op all_styles

47+ ++ map setStyleOp allStyles

49instance Arbitrary Attr where

50− arbitrary = elements possible_attr_mods >>= return . flip apply_op def_attr

50+ arbitrary = elements possibleAttrMods >>= return . flip applyOp defAttr

52data DiffAttr = DiffAttr Attr Attr

54instance Arbitrary DiffAttr where

55 arbitrary = do

56− op0 <- elements possible_attr_mods

56+ op0 <- elements possibleAttrMods

57− let possible_attr_mods' = delete op0 possible_attr_mods

57+ let possibleAttrMods' = delete op0 possibleAttrMods

58− op1 <- elements possible_attr_mods'

58+ op1 <- elements possibleAttrMods'

59− return $ DiffAttr (apply_op op0 def_attr) (apply_op op1 def_attr)

59+ return $ DiffAttr (applyOp op0 defAttr) (applyOp op1 defAttr)

61data AttrOp = AttrOp String (Attr -> Attr)

63instance Eq AttrOp where

64 AttrOp n0 _ == AttrOp n1 _ = n0 == n1

66−set_style_op s = AttrOp "set_style" (flip with_style s)

66+setStyleOp s = AttrOp "set_style" (flip withStyle s)

67−set_fore_color_op c = AttrOp "set_fore_color" (flip with_fore_color c)

67+setForeColorOp c = AttrOp "set_fore_color" (flip withForeColor c)

68−set_back_color_op c = AttrOp "set_back_color" (flip with_back_color c)

68+setBackColorOp c = AttrOp "set_back_color" (flip withBackColor c)

69−id_op = AttrOp "id" id

69+idOp = AttrOp "id" id

71−apply_op :: AttrOp -> Attr -> Attr

71+applyOp :: AttrOp -> Attr -> Attr

72−apply_op (AttrOp _ f) a = f a

72+applyOp (AttrOp _ f) a = f a

test/Verify/Graphics/Vty/Image.hs+55−55

@@ -27,18 +27,18 @@ data DefaultImage = DefaultImage Image

28instance Show DefaultImage where

29 show (DefaultImage i)

30− = "DefaultImage (" ++ show i ++ ") " ++ show (image_width i, image_height i)

30+ = "DefaultImage (" ++ show i ++ ") " ++ show (imageWidth i, imageHeight i)

32instance Arbitrary DefaultImage where

33 arbitrary = do

34− i <- return $ char def_attr 'X'

34+ i <- return $ char defAttr 'X'

35 return $ DefaultImage i

37data SingleRowSingleAttrImage

38 = SingleRowSingleAttrImage

39− { expected_attr :: Attr

39+ { expectedAttr :: Attr

40− , expected_columns :: Int

40+ , expectedColumns :: Int

41− , row_image :: Image

41+ , rowImage :: Image

42 }

44instance Show SingleRowSingleAttrImage where

@@ -52,10 +52,10 @@ instance Arbitrary WidthResize where

52 WidthResize f <- arbitrary

53 w <- choose (1,64)

54 oneof $ map (return . WidthResize)

55− [ \i -> (i, image_width i)

55+ [ \i -> (i, imageWidth i)

56− , \i -> (resize_width w $ fst $ f i, w)

56+ , \i -> (resizeWidth w $ fst $ f i, w)

57− , \i -> let i' = fst $ f i in (crop_left w i', min (image_width i') w)

57+ , \i -> let i' = fst $ f i in (cropLeft w i', min (imageWidth i') w)

58− , \i -> let i' = fst $ f i in (crop_right w i', min (image_width i') w)

58+ , \i -> let i' = fst $ f i in (cropRight w i', min (imageWidth i') w)

59 ]

61newtype HeightResize = HeightResize (Image -> (Image, Int))

@@ -65,36 +65,36 @@ instance Arbitrary HeightResize where

65 HeightResize f <- arbitrary

66 h <- choose (1,64)

67 oneof $ map (return . HeightResize)

68− [ \i -> (i, image_height i)

68+ [ \i -> (i, imageHeight i)

69− , \i -> (resize_height h $ fst $ f i, h)

69+ , \i -> (resizeHeight h $ fst $ f i, h)

70− , \i -> let i' = fst $ f i in (crop_top h i', min (image_height i') h)

70+ , \i -> let i' = fst $ f i in (cropTop h i', min (imageHeight i') h)

71− , \i -> let i' = fst $ f i in (crop_bottom h i', min (image_height i') h)

71+ , \i -> let i' = fst $ f i in (cropBottom h i', min (imageHeight i') h)

72 ]

74newtype ImageResize = ImageResize (Image -> (Image, (Int, Int)))

76instance Arbitrary ImageResize where

77 arbitrary = oneof

78− [ return $! ImageResize $! \i -> (i, (image_width i, image_height i))

78+ [ return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))

79− , return $! ImageResize $! \i -> (i, (image_width i, image_height i))

79+ , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))

80− , return $! ImageResize $! \i -> (i, (image_width i, image_height i))

80+ , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))

81− , return $! ImageResize $! \i -> (i, (image_width i, image_height i))

81+ , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))

82− , return $! ImageResize $! \i -> (i, (image_width i, image_height i))

82+ , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))

83− , return $! ImageResize $! \i -> (i, (image_width i, image_height i))

83+ , return $! ImageResize $! \i -> (i, (imageWidth i, imageHeight i))

84 , do

85 ImageResize f <- arbitrary

86 WidthResize g <- arbitrary

87 return $! ImageResize $! \i ->

88− let (i_0, (_, out_height)) = f i

88+ let (i_0, (_, outHeight)) = f i

89 g_i = g i_0

90− in (fst g_i, (snd g_i, out_height))

90+ in (fst g_i, (snd g_i, outHeight))

91 , do

92 ImageResize f <- arbitrary

93 HeightResize g <- arbitrary

94 return $! ImageResize $! \i ->

95− let (i_0, (out_width, _)) = f i

95+ let (i_0, (outWidth, _)) = f i

96 g_i = g i_0

97− in (fst g_i, (out_width, snd g_i))

97+ in (fst g_i, (outWidth, snd g_i))

98 ]

100

@@ -103,59 +103,59 @@ instance Arbitrary SingleRowSingleAttrImage where

103 -- The text must contain at least one character. Otherwise the image simplifies to the

104 -- IdImage which has a height of 0. If this is to represent a single row then the height

105 -- must be 1

106− single_column_row_text <- Verify.resize 16 (listOf1 arbitrary)

106+ singleColumnRowText <- Verify.resize 16 (listOf1 arbitrary)

107 a <- arbitrary

108− let out_image = horiz_cat $ [char a c | SingleColumnChar c <- single_column_row_text]

108+ let outImage = horizCat $ [char a c | SingleColumnChar c <- singleColumnRowText]

109− out_width = length single_column_row_text

109+ outWidth = length singleColumnRowText

110− return $ SingleRowSingleAttrImage a out_width out_image

110+ return $ SingleRowSingleAttrImage a outWidth outImage

111

112data SingleRowTwoAttrImage

113 = SingleRowTwoAttrImage

114− { part_0 :: SingleRowSingleAttrImage

114+ { part0 :: SingleRowSingleAttrImage

115− , part_1 :: SingleRowSingleAttrImage

115+ , part1 :: SingleRowSingleAttrImage

116− , join_image :: Image

116+ , joinImage :: Image

117 } deriving Show

118

119instance Arbitrary SingleRowTwoAttrImage where

120 arbitrary = do

121 p0 <- arbitrary

122 p1 <- arbitrary

123− return $ SingleRowTwoAttrImage p0 p1 (row_image p0 <|> row_image p1)

123+ return $ SingleRowTwoAttrImage p0 p1 (rowImage p0 <|> rowImage p1)

124

125data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack

126− { stack_image :: Image

126+ { stackImage :: Image

127− , stack_source_images :: [SingleRowSingleAttrImage]

127+ , stackSourceImages :: [SingleRowSingleAttrImage]

128− , stack_width :: Int

128+ , stackWidth :: Int

129− , stack_height :: Int

129+ , stackHeight :: Int

130 }

131 deriving Show

132

133instance Arbitrary SingleAttrSingleSpanStack where

134 arbitrary = do

135− image_list <- Verify.resize 16 (listOf1 arbitrary)

135+ imageList <- Verify.resize 16 (listOf1 arbitrary)

136− return $ mk_single_attr_single_span_stack image_list

136+ return $ mkSingleAttrSingleSpanStack imageList

137 shrink s = do

138− image_list <- shrink $ stack_source_images s

138+ imageList <- shrink $ stackSourceImages s

139− if null image_list

139+ if null imageList

140 then []

141− else return $ mk_single_attr_single_span_stack image_list

141+ else return $ mkSingleAttrSingleSpanStack imageList

142

143−mk_single_attr_single_span_stack image_list =

143+mkSingleAttrSingleSpanStack imageList =

144− let image = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- image_list ]

144+ let image = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- imageList ]

145− in SingleAttrSingleSpanStack image image_list (maximum $ map expected_columns image_list)

145+ in SingleAttrSingleSpanStack image imageList (maximum $ map expectedColumns imageList)

146− (toEnum $ length image_list)

146+ (toEnum $ length imageList)

147

148instance Arbitrary Image where

149 arbitrary = oneof

150 [ return EmptyImage

151 , do

152− SingleAttrSingleSpanStack {stack_image} <- Verify.resize 8 arbitrary

152+ SingleAttrSingleSpanStack {stackImage} <- Verify.resize 8 arbitrary

153 ImageResize f <- Verify.resize 2 arbitrary

154− return $! fst $! f stack_image

154+ return $! fst $! f stackImage

155 , do

156− SingleAttrSingleSpanStack {stack_image} <- Verify.resize 8 arbitrary

156+ SingleAttrSingleSpanStack {stackImage} <- Verify.resize 8 arbitrary

157 ImageResize f <- Verify.resize 2 arbitrary

158− return $! fst $! f stack_image

158+ return $! fst $! f stackImage

159 , do

160 i_0 <- arbitrary

161 i_1 <- arbitrary

@@ -171,28 +171,28 @@ instance Arbitrary Image where

171 ]

172 {-

173 shrink i@(HorizJoin {part_left, part_right}) = do

174− let !i_alt = background_fill (image_width i) (image_height i)

174+ let !i_alt = background_fill (imageWidth i) (imageHeight i)

175 !part_left' <- shrink part_left

176 !part_right' <- shrink part_right

177 [i_alt, part_left' <|> part_right']

178 shrink i@(VertJoin {part_top, part_bottom}) = do

179− let !i_alt = background_fill (image_width i) (image_height i)

179+ let !i_alt = background_fill (imageWidth i) (imageHeight i)

180 !part_top' <- shrink part_top

181 !part_bottom' <- shrink part_bottom

182 [i_alt, part_top' <-> part_bottom']

183 shrink i@(CropRight {cropped_image, output_width}) = do

184− let !i_alt = background_fill (image_width i) (image_height i)

184+ let !i_alt = background_fill (imageWidth i) (imageHeight i)

185 [i_alt, cropped_image]

186 shrink i@(CropLeft {cropped_image, left_skip, output_width}) = do

187− let !i_alt = background_fill (image_width i) (image_height i)

187+ let !i_alt = background_fill (imageWidth i) (imageHeight i)

188 [i_alt, cropped_image]

189 shrink i@(CropBottom {cropped_image, output_height}) = do

190− let !i_alt = background_fill (image_width i) (image_height i)

190+ let !i_alt = background_fill (imageWidth i) (imageHeight i)

191 [i_alt, cropped_image]

192 shrink i@(CropTop {cropped_image, top_skip, output_height}) = do

193− let !i_alt = background_fill (image_width i) (image_height i)

193+ let !i_alt = background_fill (imageWidth i) (imageHeight i)

194 [i_alt, cropped_image]

195− shrink i = [empty_image, background_fill (image_width i) (image_height i)]

195+ shrink i = [empty_image, background_fill (imageWidth i) (imageHeight i)]

196 -}

197

198data CropOperation

test/Verify/Graphics/Vty/Output.hs+10−10

@@ -12,8 +12,8 @@ import Test.QuickCheck.Property

12-- This started with a list of terminals ubuntu supported. Then those terminals that really could

13-- not be supported were removed. Then a few more were pruned until a reasonable looking set was

14-- made.

15−terminals_of_interest :: [String]

15+terminalsOfInterest :: [String]

16−terminals_of_interest =

16+terminalsOfInterest =

17 [ "vt100"

18 , "vt220"

19 , "vt102"

@@ -47,14 +47,14 @@ terminals_of_interest =

47 , "cygwin"

48 ]

50−compare_mock_output :: MockData -> String -> IO Result

50+compareMockOutput :: MockData -> String -> IO Result

51−compare_mock_output mock_data expected_str = do

51+compareMockOutput mockData expectedStr = do

52− out_bytes <- readIORef mock_data >>= return . UTF8.toRep

52+ outBytes <- readIORef mockData >>= return . UTF8.toRep

53− let expected_bytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expected_str

53+ let expectedBytes :: BS.ByteString = UTF8.toRep $ UTF8.fromString expectedStr

54− if out_bytes /= expected_bytes

54+ if outBytes /= expectedBytes

55− then return $ failed { reason = "bytes\n" ++ show out_bytes

55+ then return $ failed { reason = "bytes\n" ++ show outBytes

56− ++ "\nare not the expected bytes\n"

56+ ++ "\nare not the expected bytes\n"

57− ++ show expected_bytes

57+ ++ show expectedBytes

58 }

59 else return succeeded

test/Verify/Graphics/Vty/Picture.hs+10−10

@@ -15,8 +15,8 @@ import Verify.Graphics.Vty.Image

15import Verify

17data DefaultPic = DefaultPic

18− { default_pic :: Picture

18+ { defaultPic :: Picture

19− , default_win :: MockWindow

19+ , defaultWin :: MockWindow

20 }

22instance Show DefaultPic where

@@ -26,27 +26,27 @@ instance Show DefaultPic where

26instance Arbitrary DefaultPic where

27 arbitrary = do

28 DefaultImage image <- arbitrary

29− let win = MockWindow (image_width image) (image_height image)

29+ let win = MockWindow (imageWidth image) (imageHeight image)

30− return $ DefaultPic (pic_for_image image)

30+ return $ DefaultPic (picForImage image)

31 win

33data PicWithBGAttr = PicWithBGAttr

34− { with_attr_pic :: Picture

34+ { withAttrPic :: Picture

35− , with_attr_win :: MockWindow

35+ , withAttrWin :: MockWindow

36− , with_attr_specified_attr :: Attr

36+ , withAttrSpecifiedAttr :: Attr

37 } deriving ( Show )

39instance Arbitrary PicWithBGAttr where

40 arbitrary = do

41 DefaultImage image <- arbitrary

42− let win = MockWindow (image_width image) (image_height image)

42+ let win = MockWindow (imageWidth image) (imageHeight image)

43 attr <- arbitrary

44− return $ PicWithBGAttr (pic_for_image image)

44+ return $ PicWithBGAttr (picForImage image)

45 win

46 attr

48instance Arbitrary Picture where

49 arbitrary = do

50 layers <- Verify.resize 20 (listOf1 arbitrary)

51− return $ pic_for_layers layers

51+ return $ picForLayers layers

test/Verify/Graphics/Vty/Span.hs+6−6

@@ -14,12 +14,12 @@ import Data.Word

15import Verify

17−is_attr_span_op :: SpanOp -> Bool

17+isAttrSpanOp :: SpanOp -> Bool

18−is_attr_span_op TextSpan {} = True

18+isAttrSpanOp TextSpan {} = True

19−is_attr_span_op _ = False

19+isAttrSpanOp _ = False

21−verify_all_spans_have_width i spans w

21+verifyAllSpansHaveWidth i spans w

22− = let v = map (\s -> (span_ops_effected_columns s /= w, s)) (Vector.toList spans)

22+ = let v = map (\s -> (spanOpsEffectedColumns s /= w, s)) (Vector.toList spans)

23 in case any ((== True) . fst) v of

24 False -> succeeded

25 True -> failed { reason = "Not all spans contained operations defining exactly "

@@ -28,7 +28,7 @@ verify_all_spans_have_width i spans w

28 ++ (concatMap ((++ "\n") . show)) v

29 }

31−verify_ops_equality i_ops i_alt_ops =

31+verifyOpsEquality i_ops i_alt_ops =

32 if i_ops == i_alt_ops

33 then succeeded

34 else failed { reason = "ops for alternate image " ++ show i_alt_ops

test/VerifyCropSpanGeneration.hs+55−55

@@ -15,79 +15,79 @@ import Verify

16import qualified Data.Vector as Vector

18−crop_op_display_ops :: (Int -> Image -> Image) ->

18+cropOpDisplayOps :: (Int -> Image -> Image) ->

19− Int -> Image -> (DisplayOps, Image)

19+ Int -> Image -> (DisplayOps, Image)

20−crop_op_display_ops crop_op v i =

20+cropOpDisplayOps cropOp v i =

21− let i_out = crop_op v i

21+ let iOut = cropOp v i

22− p = pic_for_image i_out

22+ p = picForImage iOut

23− w = MockWindow (image_width i_out) (image_height i_out)

23+ w = MockWindow (imageWidth iOut) (imageHeight iOut)

24− in (display_ops_for_pic p (region_for_window w), i_out)

24+ in (displayOpsForPic p (regionForWindow w), iOut)

25−

25+

26−width_crop_output_columns :: (Int -> Image -> Image) ->

26+widthCropOutputColumns :: (Int -> Image -> Image) ->

27− SingleAttrSingleSpanStack ->

27+ SingleAttrSingleSpanStack ->

28− NonNegative Int ->

28+ NonNegative Int ->

29− Property

29+ Property

30−width_crop_output_columns crop_op s (NonNegative w) = stack_width s > w ==>

30+widthCropOutputColumns cropOp s (NonNegative w) = stackWidth s > w ==>

31− let (ops, i_out) = crop_op_display_ops crop_op w (stack_image s)

31+ let (ops, iOut) = cropOpDisplayOps cropOp w (stackImage s)

32− in verify_all_spans_have_width i_out ops w

32+ in verifyAllSpansHaveWidth iOut ops w

33−

33+

34−height_crop_output_columns :: (Int -> Image -> Image) ->

34+heightCropOutputColumns :: (Int -> Image -> Image) ->

35− SingleAttrSingleSpanStack ->

35+ SingleAttrSingleSpanStack ->

36− NonNegative Int ->

36+ NonNegative Int ->

37− Property

37+ Property

38−height_crop_output_columns crop_op s (NonNegative h) = stack_height s > h ==>

38+heightCropOutputColumns cropOp s (NonNegative h) = stackHeight s > h ==>

39− let (ops, _) = crop_op_display_ops crop_op h (stack_image s)

39+ let (ops, _) = cropOpDisplayOps cropOp h (stackImage s)

40− in display_ops_rows ops == h

40+ in displayOpsRows ops == h

41−

41+

42−crop_right_output_columns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property

42+cropRightOutputColumns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property

43−crop_right_output_columns = width_crop_output_columns crop_right

43+cropRightOutputColumns = widthCropOutputColumns cropRight

44−

44+

45−crop_left_output_columns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property

45+cropLeftOutputColumns :: SingleAttrSingleSpanStack -> NonNegative Int -> Property

46−crop_left_output_columns = width_crop_output_columns crop_left

46+cropLeftOutputColumns = widthCropOutputColumns cropLeft

47−

47+

48−crop_top_output_rows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property

48+cropTopOutputRows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property

49−crop_top_output_rows = height_crop_output_columns crop_top

49+cropTopOutputRows = heightCropOutputColumns cropTop

50−

50+

51−crop_bottom_output_rows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property

51+cropBottomOutputRows :: SingleAttrSingleSpanStack -> NonNegative Int -> Property

52−crop_bottom_output_rows = height_crop_output_columns crop_bottom

52+cropBottomOutputRows = heightCropOutputColumns cropBottom

54-- TODO: known benign failure.

55−crop_right_and_left_rejoined_equivalence :: SingleAttrSingleSpanStack -> Property

55+cropRightAndLeftRejoinedEquivalence :: SingleAttrSingleSpanStack -> Property

56−crop_right_and_left_rejoined_equivalence stack = image_width (stack_image stack) `mod` 2 == 0 ==>

56+cropRightAndLeftRejoinedEquivalence stack = imageWidth (stackImage stack) `mod` 2 == 0 ==>

57− let i = stack_image stack

57+ let i = stackImage stack

58 -- the right part is made by cropping the image from the left.

59− i_r = crop_left (image_width i `div` 2) i

59+ i_r = cropLeft (imageWidth i `div` 2) i

60 -- the left part is made by cropping the image from the right

61− i_l = crop_right (image_width i `div` 2) i

61+ i_l = cropRight (imageWidth i `div` 2) i

62 i_alt = i_l <|> i_r

63− i_ops = display_ops_for_image i

63+ i_ops = displayOpsForImage i

64− i_alt_ops = display_ops_for_image i_alt

64+ i_alt_ops = displayOpsForImage i_alt

65− in verify_ops_equality i_ops i_alt_ops

65+ in verifyOpsEquality i_ops i_alt_ops

67−crop_top_and_bottom_rejoined_equivalence :: SingleAttrSingleSpanStack -> Property

67+cropTopAndBottomRejoinedEquivalence :: SingleAttrSingleSpanStack -> Property

68−crop_top_and_bottom_rejoined_equivalence stack = image_height (stack_image stack) `mod` 2 == 0 ==>

68+cropTopAndBottomRejoinedEquivalence stack = imageHeight (stackImage stack) `mod` 2 == 0 ==>

69− let i = stack_image stack

69+ let i = stackImage stack

70 -- the top part is made by cropping the image from the bottom.

71− i_t = crop_bottom (image_height i `div` 2) i

71+ i_t = cropBottom (imageHeight i `div` 2) i

72 -- the bottom part is made by cropping the image from the top.

73− i_b = crop_top (image_height i `div` 2) i

73+ i_b = cropTop (imageHeight i `div` 2) i

74 i_alt = i_t <-> i_b

75− in display_ops_for_image i == display_ops_for_image i_alt

75+ in displayOpsForImage i == displayOpsForImage i_alt

77tests :: IO [Test]

78tests = return

79 [ verify "cropping from the bottom produces display operations covering the expected rows"

80− crop_bottom_output_rows

80+ cropBottomOutputRows

81 , verify "cropping from the top produces display operations covering the expected rows"

82− crop_top_output_rows

82+ cropTopOutputRows

83 , verify "cropping from the left produces display operations covering the expected columns"

84− crop_left_output_columns

84+ cropLeftOutputColumns

85 , verify "cropping from the right produces display operations covering the expected columns"

86− crop_right_output_columns

86+ cropRightOutputColumns

87 -- TODO: known benign failure.

88 -- , verify "the output of a stack is the same as that stack cropped left & right and joined together"

89− -- crop_right_and_left_rejoined_equivalence

89+ -- cropRightAndLeftRejoinedEquivalence

90 , verify "the output of a stack is the same as that stack cropped top & bottom and joined together"

91− crop_top_and_bottom_rejoined_equivalence

91+ cropTopAndBottomRejoinedEquivalence

92 ]

test/VerifyEmptyImageProps.hs+2−2

@@ -3,11 +3,11 @@ module VerifyEmptyImageProps where

3import Verify

5-- should be exported by Graphics.Vty.Picture

6−import Graphics.Vty.Picture ( Image, empty_image )

6+import Graphics.Vty.Picture ( Image, emptyImage )

8tests :: IO [Test]

9tests = do

10 -- should provide an image type.

11− let _ :: Image = empty_image

11+ let _ :: Image = emptyImage

12 return []

test/VerifyEvalTerminfoCaps.hs+26−26

@@ -25,7 +25,7 @@ import Foreign.Ptr (Ptr, minusPtr)

25import Numeric

27-- If a terminal defines one of the caps then it's expected to be parsable.

28−caps_of_interest =

28+capsOfInterest =

29 [ "cup"

30 , "sc"

31 , "rc"

@@ -45,45 +45,45 @@ caps_of_interest =

45 , "sgr0"

46 ]

48−from_capname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name)

48+fromCapname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name)

50tests :: IO [Test]

51tests = do

52− eval_buffer :: Ptr Word8 <- mallocBytes (1024 * 1024) -- Should be big enough for any termcaps ;-)

52+ evalBuffer :: Ptr Word8 <- mallocBytes (1024 * 1024) -- Should be big enough for any termcaps ;-)

53− fmap concat $ forM terminals_of_interest $ \term_name -> do

53+ fmap concat $ forM terminalsOfInterest $ \termName -> do

54− putStrLn $ "adding tests for terminal: " ++ term_name

54+ putStrLn $ "adding tests for terminal: " ++ termName

55− mti <- try $ Terminfo.setupTerm term_name

55+ mti <- try $ Terminfo.setupTerm termName

56 case mti of

57 Left (_e :: SomeException)

58 -> return []

59 Right ti -> do

60− fmap concat $ forM caps_of_interest $ \cap_name -> do

60+ fmap concat $ forM capsOfInterest $ \capName -> do

61− case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of

61+ case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of

62− Just cap_def -> do

62+ Just capDef -> do

63− putStrLn $ "\tadding test for cap: " ++ cap_name

63+ putStrLn $ "\tadding test for cap: " ++ capName

64− let test_name = term_name ++ "(" ++ cap_name ++ ")"

64+ let testName = termName ++ "(" ++ capName ++ ")"

65− case parse_cap_expression cap_def of

65+ case parseCapExpression capDef of

66− Left error -> return [verify test_name (failed {reason = "parse error " ++ show error})]

66+ Left error -> return [verify testName (failed {reason = "parse error " ++ show error})]

67− Right !cap_expr -> return [verify test_name (verify_eval_cap eval_buffer cap_expr)]

67+ Right !cap_expr -> return [verify testName (verifyEvalCap evalBuffer cap_expr)]

68 Nothing -> do

69 return []

71−{-# NOINLINE verify_eval_cap #-}

71+{-# NOINLINE verifyEvalCap #-}

72−verify_eval_cap :: Ptr Word8 -> CapExpression -> Int -> Property

72+verifyEvalCap :: Ptr Word8 -> CapExpression -> Int -> Property

73−verify_eval_cap eval_buffer expr !junk_int = do

73+verifyEvalCap evalBuffer expr !junkInt = do

74− forAll (vector 9) $ \input_values ->

74+ forAll (vector 9) $ \inputValues ->

75− let write = write_cap_expr expr input_values

75+ let write = writeCapExpr expr inputValues

76− !byte_count = getBound write

76+ !byteCount = getBound write

77 in liftIOResult $ do

78− let start_ptr :: Ptr Word8 = eval_buffer

78+ let startPtr :: Ptr Word8 = evalBuffer

79− forM_ [0..100] $ \i -> runWrite write start_ptr

79+ forM_ [0..100] $ \i -> runWrite write startPtr

80− end_ptr <- runWrite write start_ptr

80+ endPtr <- runWrite write startPtr

81− case end_ptr `minusPtr` start_ptr of

81+ case endPtr `minusPtr` startPtr of

82 count | count < 0 ->

83 return $ failed { reason = "End pointer before start pointer." }

84− | toEnum count > byte_count ->

84+ | toEnum count > byteCount ->

85 return $ failed { reason = "End pointer past end of buffer by "

86− ++ show (toEnum count - byte_count)

86+ ++ show (toEnum count - byteCount)

87 }

88 | otherwise ->

89 return succeeded

test/VerifyImageOps.hs+113−113

@@ -8,167 +8,167 @@ import Verify

9import Control.DeepSeq

11−two_sw_horiz_concat :: SingleColumnChar -> SingleColumnChar -> Bool

11+twoSwHorizConcat :: SingleColumnChar -> SingleColumnChar -> Bool

12−two_sw_horiz_concat (SingleColumnChar c1) (SingleColumnChar c2) =

12+twoSwHorizConcat (SingleColumnChar c1) (SingleColumnChar c2) =

13− image_width (char def_attr c1 <|> char def_attr c2) == 2

13+ imageWidth (char defAttr c1 <|> char defAttr c2) == 2

15−many_sw_horiz_concat :: [SingleColumnChar] -> Bool

15+manySwHorizConcat :: [SingleColumnChar] -> Bool

16−many_sw_horiz_concat cs =

16+manySwHorizConcat cs =

17 let chars = [ char | SingleColumnChar char <- cs ]

18 l = fromIntegral $ length cs

19− in image_width ( horiz_cat $ map (char def_attr) chars ) == l

19+ in imageWidth ( horizCat $ map (char defAttr) chars ) == l

21−two_sw_vert_concat :: SingleColumnChar -> SingleColumnChar -> Bool

21+twoSwVertConcat :: SingleColumnChar -> SingleColumnChar -> Bool

22−two_sw_vert_concat (SingleColumnChar c1) (SingleColumnChar c2) =

22+twoSwVertConcat (SingleColumnChar c1) (SingleColumnChar c2) =

23− image_height (char def_attr c1 <-> char def_attr c2) == 2

23+ imageHeight (char defAttr c1 <-> char defAttr c2) == 2

25−horiz_concat_sw_assoc :: SingleColumnChar -> SingleColumnChar -> SingleColumnChar -> Bool

25+horizConcatSwAssoc :: SingleColumnChar -> SingleColumnChar -> SingleColumnChar -> Bool

26−horiz_concat_sw_assoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) =

26+horizConcatSwAssoc (SingleColumnChar c0) (SingleColumnChar c1) (SingleColumnChar c2) =

27− (char def_attr c0 <|> char def_attr c1) <|> char def_attr c2

27+ (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2

28 ==

29− char def_attr c0 <|> (char def_attr c1 <|> char def_attr c2)

29+ char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2)

31−two_dw_horiz_concat :: DoubleColumnChar -> DoubleColumnChar -> Bool

31+twoDwHorizConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool

32−two_dw_horiz_concat (DoubleColumnChar c1) (DoubleColumnChar c2) =

32+twoDwHorizConcat (DoubleColumnChar c1) (DoubleColumnChar c2) =

33− image_width (char def_attr c1 <|> char def_attr c2) == 4

33+ imageWidth (char defAttr c1 <|> char defAttr c2) == 4

35−many_dw_horiz_concat :: [DoubleColumnChar] -> Bool

35+manyDwHorizConcat :: [DoubleColumnChar] -> Bool

36−many_dw_horiz_concat cs =

36+manyDwHorizConcat cs =

37 let chars = [ char | DoubleColumnChar char <- cs ]

38 l = fromIntegral $ length cs

39− in image_width ( horiz_cat $ map (char def_attr) chars ) == l * 2

39+ in imageWidth ( horizCat $ map (char defAttr) chars ) == l * 2

41−two_dw_vert_concat :: DoubleColumnChar -> DoubleColumnChar -> Bool

41+twoDwVertConcat :: DoubleColumnChar -> DoubleColumnChar -> Bool

42−two_dw_vert_concat (DoubleColumnChar c1) (DoubleColumnChar c2) =

42+twoDwVertConcat (DoubleColumnChar c1) (DoubleColumnChar c2) =

43− image_height (char def_attr c1 <-> char def_attr c2) == 2

43+ imageHeight (char defAttr c1 <-> char defAttr c2) == 2

45−horiz_concat_dw_assoc :: DoubleColumnChar -> DoubleColumnChar -> DoubleColumnChar -> Bool

45+horizConcatDwAssoc :: DoubleColumnChar -> DoubleColumnChar -> DoubleColumnChar -> Bool

46−horiz_concat_dw_assoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) =

46+horizConcatDwAssoc (DoubleColumnChar c0) (DoubleColumnChar c1) (DoubleColumnChar c2) =

47− (char def_attr c0 <|> char def_attr c1) <|> char def_attr c2

47+ (char defAttr c0 <|> char defAttr c1) <|> char defAttr c2

48 ==

49− char def_attr c0 <|> (char def_attr c1 <|> char def_attr c2)

49+ char defAttr c0 <|> (char defAttr c1 <|> char defAttr c2)

51−vert_contat_single_row :: NonEmptyList SingleRowSingleAttrImage -> Bool

51+vertContatSingleRow :: NonEmptyList SingleRowSingleAttrImage -> Bool

52−vert_contat_single_row (NonEmpty stack) =

52+vertContatSingleRow (NonEmpty stack) =

53− let expected_height :: Int = length stack

53+ let expectedHeight :: Int = length stack

54− stack_image = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack ]

54+ stackImage = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack ]

55− in image_height stack_image == expected_height

55+ in imageHeight stackImage == expectedHeight

57−disjoint_height_horiz_join :: NonEmptyList SingleRowSingleAttrImage

57+disjointHeightHorizJoin :: NonEmptyList SingleRowSingleAttrImage

58 -> NonEmptyList SingleRowSingleAttrImage

59 -> Bool

60−disjoint_height_horiz_join (NonEmpty stack_0) (NonEmpty stack_1) =

60+disjointHeightHorizJoin (NonEmpty stack_0) (NonEmpty stack_1) =

61− let expected_height :: Int = max (length stack_0) (length stack_1)

61+ let expectedHeight :: Int = max (length stack_0) (length stack_1)

62− stack_image_0 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]

62+ stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack_0 ]

63− stack_image_1 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]

63+ stackImage1 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack_1 ]

64− in image_height (stack_image_0 <|> stack_image_1) == expected_height

64+ in imageHeight (stackImage0 <|> stackImage1) == expectedHeight

67−disjoint_height_horiz_join_bg_fill :: NonEmptyList SingleRowSingleAttrImage

67+disjointHeightHorizJoinBgFill :: NonEmptyList SingleRowSingleAttrImage

68 -> NonEmptyList SingleRowSingleAttrImage

69 -> Bool

70−disjoint_height_horiz_join_bg_fill (NonEmpty stack_0) (NonEmpty stack_1) =

70+disjointHeightHorizJoinBgFill (NonEmpty stack_0) (NonEmpty stack_1) =

71− let stack_image_0 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]

71+ let stackImage0 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack_0 ]

72− stack_image_1 = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]

72+ stackImage1 = vertCat [ i | SingleRowSingleAttrImage { rowImage = i } <- stack_1 ]

73− image = stack_image_0 <|> stack_image_1

73+ image = stackImage0 <|> stackImage1

74− expected_height = image_height image

74+ expectedHeight = imageHeight image

75 in case image of

76− HorizJoin {} -> ( expected_height == (image_height $ part_left image) )

76+ HorizJoin {} -> ( expectedHeight == (imageHeight $ partLeft image) )

77 &&

78− ( expected_height == (image_height $ part_right image) )

78+ ( expectedHeight == (imageHeight $ partRight image) )

79 _ -> True

81−disjoint_width_vert_join :: NonEmptyList SingleRowSingleAttrImage

81+disjointWidthVertJoin :: NonEmptyList SingleRowSingleAttrImage

82+ -> NonEmptyList SingleRowSingleAttrImage

83+ -> Bool

84+disjointWidthVertJoin (NonEmpty stack_0) (NonEmpty stack_1) =

85+ let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images)

86+ stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack_0 ]

87+ stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack_1 ]

88+ stack0Image = vertCat stack0Images

89+ stack1Image = vertCat stack1Images

90+ image = stack0Image <-> stack1Image

91+ in imageWidth image == expectedWidth

92+

93+disjointWidthVertJoinBgFill :: NonEmptyList SingleRowSingleAttrImage

82 -> NonEmptyList SingleRowSingleAttrImage

94 -> NonEmptyList SingleRowSingleAttrImage

83 -> Bool

95 -> Bool

84−disjoint_width_vert_join (NonEmpty stack_0) (NonEmpty stack_1) =

96+disjointWidthVertJoinBgFill (NonEmpty stack_0) (NonEmpty stack_1) =

85− let expected_width = maximum $ map image_width (stack_0_images ++ stack_1_images)

97+ let expectedWidth = maximum $ map imageWidth (stack0Images ++ stack1Images)

86− stack_0_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]

98+ stack0Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack_0 ]

87− stack_1_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]

99+ stack1Images = [ i | SingleRowSingleAttrImage { rowImage = i } <- stack_1 ]

88− stack_0_image = vert_cat stack_0_images

100+ stack0Image = vertCat stack0Images

89− stack_1_image = vert_cat stack_1_images

101+ stack1Image = vertCat stack1Images

90− image = stack_0_image <-> stack_1_image

102+ image = stack0Image <-> stack1Image

91− in image_width image == expected_width

92−

93−disjoint_width_vert_join_bg_fill :: NonEmptyList SingleRowSingleAttrImage

94− -> NonEmptyList SingleRowSingleAttrImage

95− -> Bool

96−disjoint_width_vert_join_bg_fill (NonEmpty stack_0) (NonEmpty stack_1) =

97− let expected_width = maximum $ map image_width (stack_0_images ++ stack_1_images)

98− stack_0_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_0 ]

99− stack_1_images = [ i | SingleRowSingleAttrImage { row_image = i } <- stack_1 ]

100− stack_0_image = vert_cat stack_0_images

101− stack_1_image = vert_cat stack_1_images

102− image = stack_0_image <-> stack_1_image

103 in case image of

104− VertJoin {} -> ( expected_width == (image_width $ part_top image) )

104+ VertJoin {} -> ( expectedWidth == (imageWidth $ partTop image) )

105 &&

106− ( expected_width == (image_width $ part_bottom image) )

106+ ( expectedWidth == (imageWidth $ partBottom image) )

107 _ -> True

108

109−translation_is_linear_on_out_size :: Translation -> Bool

109+translationIsLinearOnOutSize :: Translation -> Bool

110−translation_is_linear_on_out_size (Translation i (x,y) i') =

110+translationIsLinearOnOutSize (Translation i (x,y) i') =

111− image_width i' == image_width i + x && image_height i' == image_height i + y

111+ imageWidth i' == imageWidth i + x && imageHeight i' == imageHeight i + y

112

113−padding_is_linear_on_out_size :: Image -> Gen Bool

113+paddingIsLinearOnOutSize :: Image -> Gen Bool

114−padding_is_linear_on_out_size i = do

114+paddingIsLinearOnOutSize i = do

115 l <- offset

116 t <- offset

117 r <- offset

118 b <- offset

119 let i' = pad l t r b i

120− return $ image_width i' == image_width i + l + r && image_height i' == image_height i + t + b

120+ return $ imageWidth i' == imageWidth i + l + r && imageHeight i' == imageHeight i + t + b

121 where offset = choose (1,1024)

122

123−crop_left_limits_width :: Image -> Int -> Property

123+cropLeftLimitsWidth :: Image -> Int -> Property

124−crop_left_limits_width i v = v >= 0 ==>

124+cropLeftLimitsWidth i v = v >= 0 ==>

125− v >= image_width (crop_left v i)

125+ v >= imageWidth (cropLeft v i)

126

127−crop_right_limits_width :: Image -> Int -> Property

127+cropRightLimitsWidth :: Image -> Int -> Property

128−crop_right_limits_width i v = v >= 0 ==>

128+cropRightLimitsWidth i v = v >= 0 ==>

129− v >= image_width (crop_right v i)

129+ v >= imageWidth (cropRight v i)

130

131−crop_top_limits_height :: Image -> Int -> Property

131+cropTopLimitsHeight :: Image -> Int -> Property

132−crop_top_limits_height i v = v >= 0 ==>

132+cropTopLimitsHeight i v = v >= 0 ==>

133− v >= image_height (crop_top v i)

133+ v >= imageHeight (cropTop v i)

134

135−crop_bottom_limits_height :: Image -> Int -> Property

135+cropBottomLimitsHeight :: Image -> Int -> Property

136−crop_bottom_limits_height i v = v >= 0 ==>

136+cropBottomLimitsHeight i v = v >= 0 ==>

137− v >= image_height (crop_bottom v i)

137+ v >= imageHeight (cropBottom v i)

138

139-- rediculous tests just to satisfy my desire for nice code coverage :-P

140−can_show_image :: Image -> Bool

140+canShowImage :: Image -> Bool

141−can_show_image i = length (show i) > 0

141+canShowImage i = length (show i) > 0

142

143−can_rnf_image :: Image -> Bool

143+canRnfImage :: Image -> Bool

144−can_rnf_image i = rnf i == ()

144+canRnfImage i = rnf i == ()

145

146−can_pp_image :: Image -> Bool

146+canPpImage :: Image -> Bool

147−can_pp_image i = length (pp_image_structure i) > 0

147+canPpImage i = length (pp_image_structure i) > 0

148

149tests :: IO [Test]

150tests = return

151− [ verify "two_sw_horiz_concat" two_sw_horiz_concat

151+ [ verify "twoSwHorizConcat" twoSwHorizConcat

152− , verify "many_sw_horiz_concat" many_sw_horiz_concat

152+ , verify "manySwHorizConcat" manySwHorizConcat

153− , verify "two_sw_vert_concat" two_sw_vert_concat

153+ , verify "twoSwVertConcat" twoSwVertConcat

154− , verify "horiz_concat_sw_assoc" horiz_concat_sw_assoc

154+ , verify "horizConcatSwAssoc" horizConcatSwAssoc

155− , verify "many_dw_horiz_concat" many_dw_horiz_concat

155+ , verify "manyDwHorizConcat" manyDwHorizConcat

156− , verify "two_dw_horiz_concat" two_dw_horiz_concat

156+ , verify "twoDwHorizConcat" twoDwHorizConcat

157− , verify "two_dw_vert_concat" two_dw_vert_concat

157+ , verify "twoDwVertConcat" twoDwVertConcat

158− , verify "horiz_concat_dw_assoc" horiz_concat_dw_assoc

158+ , verify "horizConcatDwAssoc" horizConcatDwAssoc

159− , verify "single row vert concats to correct height" vert_contat_single_row

159+ , verify "single row vert concats to correct height" vertContatSingleRow

160− , verify "disjoint_height_horiz_join" disjoint_height_horiz_join

160+ , verify "disjointHeightHorizJoin" disjointHeightHorizJoin

161− , verify "disjoint_height_horiz_join BG fill" disjoint_height_horiz_join_bg_fill

161+ , verify "disjointHeightHorizJoin BG fill" disjointHeightHorizJoinBgFill

162− , verify "disjoint_width_vert_join" disjoint_width_vert_join

162+ , verify "disjointWidthVertJoin" disjointWidthVertJoin

163− , verify "disjoint_width_vert_join BG fill" disjoint_width_vert_join_bg_fill

163+ , verify "disjointWidthVertJoin BG fill" disjointWidthVertJoinBgFill

164− , verify "translation effects output dimensions linearly" translation_is_linear_on_out_size

164+ , verify "translation effects output dimensions linearly" translationIsLinearOnOutSize

165− , verify "padding effects output dimensions linearly" padding_is_linear_on_out_size

165+ , verify "padding effects output dimensions linearly" paddingIsLinearOnOutSize

166− , verify "crop left limits width" crop_left_limits_width

166+ , verify "crop left limits width" cropLeftLimitsWidth

167− , verify "crop right limits width" crop_right_limits_width

167+ , verify "crop right limits width" cropRightLimitsWidth

168− , verify "crop top limits height" crop_top_limits_height

168+ , verify "crop top limits height" cropTopLimitsHeight

169− , verify "crop bottom limits height" crop_bottom_limits_height

169+ , verify "crop bottom limits height" cropBottomLimitsHeight

170− , verify "can show image" can_show_image

170+ , verify "can show image" canShowImage

171− , verify "can rnf image" can_rnf_image

171+ , verify "can rnf image" canRnfImage

172− , verify "can pp image" can_pp_image

172+ , verify "can pp image" canPpImage

173 ]

174

test/VerifyImageTrans.hs+17−17

@@ -9,26 +9,26 @@ import Verify

10import Data.Word

12−is_horiz_text_of_columns :: Image -> Int -> Bool

12+isHorizTextOfColumns :: Image -> Int -> Bool

13−is_horiz_text_of_columns (HorizText { output_width = in_w }) expected_w = in_w == expected_w

13+isHorizTextOfColumns (HorizText { outputWidth = inW }) expectedW = inW == expectedW

14−is_horiz_text_of_columns (BGFill { output_width = in_w }) expected_w = in_w == expected_w

14+isHorizTextOfColumns (BGFill { outputWidth = inW }) expectedW = inW == expectedW

15−is_horiz_text_of_columns _image _expected_w = False

15+isHorizTextOfColumns _image _expectedW = False

16−

16+

17−verify_horiz_contat_wo_attr_change_simplifies :: SingleRowSingleAttrImage -> Bool

17+verifyHorizContatWoAttrChangeSimplifies :: SingleRowSingleAttrImage -> Bool

18−verify_horiz_contat_wo_attr_change_simplifies (SingleRowSingleAttrImage _attr char_count image) =

18+verifyHorizContatWoAttrChangeSimplifies (SingleRowSingleAttrImage _attr charCount image) =

19− is_horiz_text_of_columns image char_count

19+ isHorizTextOfColumns image charCount

20−

20+

21−verify_horiz_contat_w_attr_change_simplifies :: SingleRowTwoAttrImage -> Bool

21+verifyHorizContatWAttrChangeSimplifies :: SingleRowTwoAttrImage -> Bool

22−verify_horiz_contat_w_attr_change_simplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 char_count0 _image0)

22+verifyHorizContatWAttrChangeSimplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 charCount0 _image0)

23− (SingleRowSingleAttrImage attr1 char_count1 _image1)

23+ (SingleRowSingleAttrImage attr1 charCount1 _image1)

24− i

24+ i

25 )

26− | char_count0 == 0 || char_count1 == 0 || attr0 == attr1 = is_horiz_text_of_columns i (char_count0 + char_count1)

26+ | charCount0 == 0 || charCount1 == 0 || attr0 == attr1 = isHorizTextOfColumns i (charCount0 + charCount1)

27− | otherwise = False == is_horiz_text_of_columns i (char_count0 + char_count1)

27+ | otherwise = False == isHorizTextOfColumns i (charCount0 + charCount1)

29tests :: IO [Test]

30tests = return

31− [ verify "verify_horiz_contat_wo_attr_change_simplifies" verify_horiz_contat_wo_attr_change_simplifies

31+ [ verify "verifyHorizContatWoAttrChangeSimplifies" verifyHorizContatWoAttrChangeSimplifies

32− , verify "verify_horiz_contat_w_attr_change_simplifies" verify_horiz_contat_w_attr_change_simplifies

32+ , verify "verifyHorizContatWAttrChangeSimplifies" verifyHorizContatWAttrChangeSimplifies

33 ]

test/VerifyInline.hs+2−2

@@ -13,13 +13,13 @@ import Distribution.TestSuite

13import System.IO

15tests :: IO [Test]

16−tests = concat <$> forM terminals_of_interest (\term_name -> return $

16+tests = concat <$> forM terminalsOfInterest (\termName -> return $

17 [ Test $ TestInstance

18 { name = "verify vty inline"

19 , run = do

20 {- disabled because I cannot get useful output out of cabal why this fails.

21 null_out <- openFile "/dev/null" WriteMode

22− t <- TerminfoBased.reserve_terminal term_name null_out

22+ t <- TerminfoBased.reserve_terminal termName null_out

23 put_attr_change t $ default_all

24 release_terminal t

25 -}

test/VerifyLayersSpanGeneration.hs+87−87

@@ -15,114 +15,114 @@ import Verify

16import qualified Data.Vector as Vector

18−larger_horiz_span_occlusion :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result

18+largerHorizSpanOcclusion :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result

19−larger_horiz_span_occlusion row_0 row_1 =

19+largerHorizSpanOcclusion row0 row1 =

20− let i_0 = row_image row_0

20+ let i0 = rowImage row0

21− i_1 = row_image row_1

21+ i1 = rowImage row1

22− (i_larger, i_smaller) = if image_width i_0 > image_width i_1 then (i_0, i_1) else (i_1, i_0)

22+ (iLarger, iSmaller) = if imageWidth i0 > imageWidth i1 then (i0, i1) else (i1, i0)

23− expected_ops = display_ops_for_image i_larger

23+ expectedOps = displayOpsForImage iLarger

24− p = pic_for_layers [i_larger, i_smaller]

24+ p = picForLayers [iLarger, iSmaller]

25− ops = display_ops_for_pic p (image_width i_larger,image_height i_larger)

25+ ops = displayOpsForPic p (imageWidth iLarger,imageHeight iLarger)

26− in verify_ops_equality expected_ops ops

26+ in verifyOpsEquality expectedOps ops

28-- | Two rows stacked vertical is equivalent to the first row rendered as the top layer and the

29-- second row rendered as a bottom layer with a background fill where the first row would be.

30−vert_stack_layer_equivalence_0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result

30+vertStackLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result

31−vert_stack_layer_equivalence_0 row_0 row_1 =

31+vertStackLayerEquivalence0 row0 row1 =

32− let i_0 = row_image row_0

32+ let i0 = rowImage row0

33− i_1 = row_image row_1

33+ i1 = rowImage row1

34− i = i_0 <-> i_1

34+ i = i0 <-> i1

35− p = pic_for_image i

35+ p = picForImage i

36− i_lower = background_fill (image_width i_0) 1 <-> i_1

36+ iLower = backgroundFill (imageWidth i0) 1 <-> i1

37− p_layered = pic_for_layers [i_0, i_lower]

37+ pLayered = picForLayers [i0, iLower]

38− expected_ops = display_ops_for_image i

38+ expectedOps = displayOpsForImage i

39− ops_layered = display_ops_for_pic p_layered (image_width i_lower,image_height i_lower)

39+ opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower)

40− in verify_ops_equality expected_ops ops_layered

40+ in verifyOpsEquality expectedOps opsLayered

42−vert_stack_layer_equivalence_1 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result

42+vertStackLayerEquivalence1 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result

43−vert_stack_layer_equivalence_1 row_0 row_1 =

43+vertStackLayerEquivalence1 row0 row1 =

44− let i_0 = row_image row_0

44+ let i0 = rowImage row0

45− i_1 = row_image row_1

45+ i1 = rowImage row1

46− i = i_0 <-> i_1

46+ i = i0 <-> i1

47− p = pic_for_image i

47+ p = picForImage i

48− i_lower = i_0 <-> background_fill (image_width i_1) 1

48+ iLower = i0 <-> backgroundFill (imageWidth i1) 1

49− i_upper = background_fill (image_width i_0) 1 <-> i_1

49+ iUpper = backgroundFill (imageWidth i0) 1 <-> i1

50− p_layered = pic_for_layers [i_upper, i_lower]

50+ pLayered = picForLayers [iUpper, iLower]

51− expected_ops = display_ops_for_image i

51+ expectedOps = displayOpsForImage i

52− ops_layered = display_ops_for_pic p_layered (image_width i_lower,image_height i_lower)

52+ opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower)

53− in verify_ops_equality expected_ops ops_layered

53+ in verifyOpsEquality expectedOps opsLayered

55-- | Two rows horiz joined is equivalent to the first row rendered as the top layer and the

56-- second row rendered as a bottom layer with a background fill where the first row would be.

57−horiz_join_layer_equivalence_0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result

57+horizJoinLayerEquivalence0 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result

58−horiz_join_layer_equivalence_0 row_0 row_1 =

58+horizJoinLayerEquivalence0 row0 row1 =

59− let i_0 = row_image row_0

59+ let i0 = rowImage row0

60− i_1 = row_image row_1

60+ i1 = rowImage row1

61− i = i_0 <|> i_1

61+ i = i0 <|> i1

62− p = pic_for_image i

62+ p = picForImage i

63− i_lower = background_fill (image_width i_0) 1 <|> i_1

63+ iLower = backgroundFill (imageWidth i0) 1 <|> i1

64− p_layered = pic_for_layers [i_0, i_lower]

64+ pLayered = picForLayers [i0, iLower]

65− expected_ops = display_ops_for_image i

65+ expectedOps = displayOpsForImage i

66− ops_layered = display_ops_for_pic p_layered (image_width i_lower,image_height i_lower)

66+ opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower)

67− in verify_ops_equality expected_ops ops_layered

67+ in verifyOpsEquality expectedOps opsLayered

69−horiz_join_layer_equivalence_1 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result

69+horizJoinLayerEquivalence1 :: SingleRowSingleAttrImage -> SingleRowSingleAttrImage -> Result

70−horiz_join_layer_equivalence_1 row_0 row_1 =

70+horizJoinLayerEquivalence1 row0 row1 =

71− let i_0 = row_image row_0

71+ let i0 = rowImage row0

72− i_1 = row_image row_1

72+ i1 = rowImage row1

73− i = i_0 <|> i_1

73+ i = i0 <|> i1

74− p = pic_for_image i

74+ p = picForImage i

75− i_lower = i_0 <|> background_fill (image_width i_1) 1

75+ iLower = i0 <|> backgroundFill (imageWidth i1) 1

76− i_upper = background_fill (image_width i_0) 1 <|> i_1

76+ iUpper = backgroundFill (imageWidth i0) 1 <|> i1

77− p_layered = pic_for_layers [i_upper, i_lower]

77+ pLayered = picForLayers [iUpper, iLower]

78− expected_ops = display_ops_for_image i

78+ expectedOps = displayOpsForImage i

79− ops_layered = display_ops_for_pic p_layered (image_width i_lower,image_height i_lower)

79+ opsLayered = displayOpsForPic pLayered (imageWidth iLower,imageHeight iLower)

80− in verify_ops_equality expected_ops ops_layered

80+ in verifyOpsEquality expectedOps opsLayered

82−horiz_join_alternate_0 :: Result

82+horizJoinAlternate0 :: Result

83−horiz_join_alternate_0 =

83+horizJoinAlternate0 =

84 let size = 4

85− str_0 = replicate size 'a'

85+ str0 = replicate size 'a'

86− str_1 = replicate size 'b'

86+ str1 = replicate size 'b'

87− i_0 = string def_attr str_0

87+ i0 = string defAttr str0

88− i_1 = string def_attr str_1

88+ i1 = string defAttr str1

89− i = horiz_cat $ zipWith horiz_join (replicate size i_0) (replicate size i_1)

89+ i = horizCat $ zipWith horizJoin (replicate size i0) (replicate size i1)

90− layer_0 = horiz_cat $ replicate size $ i_0 <|> background_fill size 1

90+ layer0 = horizCat $ replicate size $ i0 <|> backgroundFill size 1

91− layer_1 = horiz_cat $ replicate size $ background_fill size 1 <|> i_1

91+ layer1 = horizCat $ replicate size $ backgroundFill size 1 <|> i1

92− expected_ops = display_ops_for_image i

92+ expectedOps = displayOpsForImage i

93− ops_layered = display_ops_for_pic (pic_for_layers [layer_0, layer_1])

93+ opsLayered = displayOpsForPic (picForLayers [layer0, layer1])

94− (image_width i,image_height i)

94+ (imageWidth i,imageHeight i)

95− in verify_ops_equality expected_ops ops_layered

95+ in verifyOpsEquality expectedOps opsLayered

97−horiz_join_alternate_1 :: Result

97+horizJoinAlternate1 :: Result

98−horiz_join_alternate_1 =

98+horizJoinAlternate1 =

99 let size = 4

100− str_0 = replicate size 'a'

100+ str0 = replicate size 'a'

101− str_1 = replicate size 'b'

101+ str1 = replicate size 'b'

102− i_0 = string def_attr str_0

102+ i0 = string defAttr str0

103− i_1 = string def_attr str_1

103+ i1 = string defAttr str1

104− i = horiz_cat $ zipWith horiz_join (replicate size i_0) (replicate size i_1)

104+ i = horizCat $ zipWith horizJoin (replicate size i0) (replicate size i1)

105− layers = [l | b <- take 4 [0,size*2..], let l = background_fill b 1 <|> i_0 <|> i_1]

105+ layers = [l | b <- take 4 [0,size*2..], let l = backgroundFill b 1 <|> i0 <|> i1]

106− expected_ops = display_ops_for_image i

106+ expectedOps = displayOpsForImage i

107− ops_layered = display_ops_for_pic (pic_for_layers layers)

107+ opsLayered = displayOpsForPic (picForLayers layers)

108− (image_width i,image_height i)

108+ (imageWidth i,imageHeight i)

109− in verify_ops_equality expected_ops ops_layered

109+ in verifyOpsEquality expectedOps opsLayered

110

111tests :: IO [Test]

112tests = return

113 [ verify "a larger horiz span occludes a smaller span on a lower layer"

114− larger_horiz_span_occlusion

114+ largerHorizSpanOcclusion

115 , verify "two rows stack vertical equiv to first image layered on top of second with padding (0)"

116− vert_stack_layer_equivalence_0

116+ vertStackLayerEquivalence0

117 , verify "two rows stack vertical equiv to first image layered on top of second with padding (1)"

118− vert_stack_layer_equivalence_1

118+ vertStackLayerEquivalence1

119 -- , verify "two rows horiz joined equiv to first image layered on top of second with padding (0)"

120− -- horiz_join_layer_equivalence_0

120+ -- horizJoinLayerEquivalence0

121 -- , verify "two rows horiz joined equiv to first image layered on top of second with padding (1)"

122− -- horiz_join_layer_equivalence_1

122+ -- horizJoinLayerEquivalence1

123 -- , verify "alternating images using joins is the same as alternating images using layers (0)"

124− -- horiz_join_alternate_0

124+ -- horizJoinAlternate0

125 -- , verify "alternating images using joins is the same as alternating images using layers (1)"

126− -- horiz_join_alternate_1

126+ -- horizJoinAlternate1

127 ]

128

test/VerifyOutput.hs+29−29

@@ -17,47 +17,47 @@ import System.Posix.Env

17import System.IO

19tests :: IO [Test]

20−tests = concat <$> forM terminals_of_interest (\term_name -> do

20+tests = concat <$> forM terminalsOfInterest (\termName -> do

21 -- check if that terminfo exists

22− putStrLn $ "testing end to end for terminal: " ++ term_name

22+ putStrLn $ "testing end to end for terminal: " ++ termName

23− mti <- try $ Terminfo.setupTerm term_name

23+ mti <- try $ Terminfo.setupTerm termName

24 case mti of

25 Left (_ :: SomeException) -> return []

26− Right _ -> return [ verify ("verify " ++ term_name ++ " could output a picture")

26+ Right _ -> return [ verify ("verify " ++ termName ++ " could output a picture")

27− (smoke_test_term_non_mac term_name)

27+ (smokeTestTermNonMac termName)

28 -- this is excessive.

29− , verify ("verify " ++ term_name ++ " could output a picture on a Mac.")

29+ , verify ("verify " ++ termName ++ " could output a picture on a Mac.")

30− (smoke_test_term_mac term_name)

30+ (smokeTestTermMac termName)

31 ]

32 )

34−smoke_test_term_non_mac :: String -> Image -> Property

34+smokeTestTermNonMac :: String -> Image -> Property

35−smoke_test_term_non_mac term_name i = liftIOResult $ do

35+smokeTestTermNonMac termName i = liftIOResult $ do

36 -- unset the TERM_PROGRAM environment variable if set.

37 -- Required to execute regression test for #42 on a mac

38 unsetEnv "TERM_PROGRAM"

39− smoke_test_term term_name i

39+ smokeTestTerm termName i

41−smoke_test_term_mac :: String -> Image -> Property

41+smokeTestTermMac :: String -> Image -> Property

42−smoke_test_term_mac term_name i = liftIOResult $ do

42+smokeTestTermMac termName i = liftIOResult $ do

43 setEnv "TERM_PROGRAM" "Apple_Terminal" True

44− smoke_test_term term_name i

44+ smokeTestTerm termName i

45−

45+

46−smoke_test_term :: String -> Image -> IO Result

46+smokeTestTerm :: String -> Image -> IO Result

47−smoke_test_term term_name i = do

47+smokeTestTerm termName i = do

48− null_out <- openFile "/dev/null" WriteMode

48+ nullOut <- openFile "/dev/null" WriteMode

49− t <- output_for_name_and_io term_name null_out

49+ t <- outputForNameAndIO termName nullOut

50− putStrLn $ "context color count: " ++ show (context_color_count t)

50+ putStrLn $ "context color count: " ++ show (contextColorCount t)

51− reserve_display t

51+ reserveDisplay t

52− dc <- display_context t (100,100)

52+ dc <- displayContext t (100,100)

53 -- always show the cursor to produce tests for terminals with no cursor support.

54− let pic = (pic_for_image i) { pic_cursor = Cursor 0 0 }

54+ let pic = (picForImage i) { picCursor = Cursor 0 0 }

55− output_picture dc pic

55+ outputPicture dc pic

56− set_cursor_pos t 0 0

56+ setCursorPos t 0 0

57− when (supports_cursor_visibility t) $ do

57+ when (supportsCursorVisibility t) $ do

58− hide_cursor t

58+ hideCursor t

59− show_cursor t

59+ showCursor t

60− release_display t

60+ releaseDisplay t

61− release_terminal t

61+ releaseTerminal t

62 return succeeded

test/VerifyParseTerminfoCaps.hs+45−45

@@ -16,7 +16,7 @@ import Numeric

17-- If a terminal defines one of the caps then it's expected to be parsable.

18-- TODO: reduce duplication with terminfo terminal implementation.

19−caps_of_interest =

19+capsOfInterest =

20 [ "cup"

21 , "sc"

22 , "rc"

@@ -36,66 +36,66 @@ caps_of_interest =

36 , "sgr0"

37 ]

39−from_capname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name)

39+fromCapname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr name)

41tests :: IO [Test]

42tests = do

43− parse_tests <- concat <$> forM terminals_of_interest (\term_name ->

43+ parseTests <- concat <$> forM terminalsOfInterest (\termName ->

44− liftIO (try $ Terminfo.setupTerm term_name)

44+ liftIO (try $ Terminfo.setupTerm termName)

45 >>= either (\(_e :: SomeException) -> return [])

46− (\ti -> concat <$> forM caps_of_interest (\cap_name -> do

46+ (\ti -> concat <$> forM capsOfInterest (\capName -> do

47− let case_name = "\tparsing cap: " ++ cap_name

47+ let caseName = "\tparsing cap: " ++ capName

48− liftIO $ putStrLn case_name

48+ liftIO $ putStrLn caseName

49− return $ case Terminfo.getCapability ti (Terminfo.tiGetStr cap_name) of

49+ return $ case Terminfo.getCapability ti (Terminfo.tiGetStr capName) of

50− Just cap_def -> [verify (case_name ++ " -> " ++ show cap_def)

50+ Just capDef -> [verify (caseName ++ " -> " ++ show capDef)

51− (verify_parse_cap cap_def $ const succeeded)]

51+ (verifyParseCap capDef $ const succeeded)]

52 Nothing -> []

53 )

54 )

55 )

56− return $ [ verify "parse_non_paramaterized_caps" non_paramaterized_caps

56+ return $ [ verify "parse_nonParamaterizedCaps" nonParamaterizedCaps

57− , verify "parse cap string with literal %" literal_percent_caps

57+ , verify "parse cap string with literal %" literalPercentCaps

58− , verify "parse cap string with %i op" inc_first_two_caps

58+ , verify "parse cap string with %i op" incFirstTwoCaps

59− , verify "parse cap string with %pN op" push_param_caps

59+ , verify "parse cap string with %pN op" pushParamCaps

60− ] ++ parse_tests

60+ ] ++ parseTests

61−

61+

62−verify_parse_cap cap_string on_parse =

62+verifyParseCap capString onParse =

63− case parse_cap_expression cap_string of

63+ case parseCapExpression capString of

64 Left error -> failed { reason = "parse error " ++ show error }

65− Right e -> on_parse e

65+ Right e -> onParse e

67−non_paramaterized_caps (NonParamCapString cap) = do

67+nonParamaterizedCaps (NonParamCapString cap) = do

68− verify_parse_cap cap $ \e ->

68+ verifyParseCap cap $ \e ->

69− let expected_bytes = map (toEnum . fromEnum) cap

69+ let expectedBytes = map (toEnum . fromEnum) cap

70− out_bytes = bytes_for_range e 0 (length cap)

70+ outBytes = bytesForRange e 0 (length cap)

71− in verify_bytes_equal out_bytes expected_bytes

71+ in verifyBytesEqual outBytes expectedBytes

73−literal_percent_caps (LiteralPercentCap cap_string expected_bytes) = do

73+literalPercentCaps (LiteralPercentCap capString expectedBytes) = do

74− verify_parse_cap cap_string $ \e -> verify_bytes_equal (collect_bytes e) expected_bytes

74+ verifyParseCap capString $ \e -> verifyBytesEqual (collectBytes e) expectedBytes

76−inc_first_two_caps (IncFirstTwoCap cap_string expected_bytes) = do

76+incFirstTwoCaps (IncFirstTwoCap capString expectedBytes) = do

77− verify_parse_cap cap_string $ \e -> verify_bytes_equal (collect_bytes e) expected_bytes

77+ verifyParseCap capString $ \e -> verifyBytesEqual (collectBytes e) expectedBytes

79−push_param_caps (PushParamCap cap_string expected_param_count expected_bytes) = do

79+pushParamCaps (PushParamCap capString expectedParamCount expectedBytes) = do

80− verify_parse_cap cap_string $ \e ->

80+ verifyParseCap capString $ \e ->

81− let out_bytes = collect_bytes e

81+ let outBytes = collectBytes e

82− out_param_count = param_count e

82+ outParamCount = paramCount e

83− in if out_param_count == expected_param_count

83+ in if outParamCount == expectedParamCount

84− then verify_bytes_equal out_bytes expected_bytes

84+ then verifyBytesEqual outBytes expectedBytes

85 else failed { reason = "out param count /= expected param count" }

87−dec_print_param_caps (DecPrintCap cap_string expected_param_count expected_bytes) = do

87+decPrintParamCaps (DecPrintCap capString expectedParamCount expectedBytes) = do

88− verify_parse_cap cap_string $ \e ->

88+ verifyParseCap capString $ \e ->

89− let out_bytes = collect_bytes e

89+ let outBytes = collectBytes e

90− out_param_count = param_count e

90+ outParamCount = paramCount e

91− in if out_param_count == expected_param_count

91+ in if outParamCount == expectedParamCount

92− then verify_bytes_equal out_bytes expected_bytes

92+ then verifyBytesEqual outBytes expectedBytes

93 else failed { reason = "out param count /= expected param count" }

95−print_cap ti cap_name = do

95+printCap ti capName = do

96− putStrLn $ cap_name ++ ": " ++ show (from_capname ti cap_name)

96+ putStrLn $ capName ++ ": " ++ show (fromCapname ti capName)

98−print_expression ti cap_name = do

98+printExpression ti capName = do

99− let parse_result = parse_cap_expression $ from_capname ti cap_name

99+ let parseResult = parseCapExpression $ fromCapname ti capName

100− putStrLn $ cap_name ++ ": " ++ show parse_result

100+ putStrLn $ capName ++ ": " ++ show parseResult

101

test/VerifySimpleSpanGeneration.hs+154−154

@@ -15,174 +15,174 @@ import Verify

16import qualified Data.Vector as Vector

18−unit_image_and_zero_window_0 :: UnitImage -> EmptyWindow -> Bool

18+unitImageAndZeroWindow0 :: UnitImage -> EmptyWindow -> Bool

19−unit_image_and_zero_window_0 (UnitImage _ i) (EmptyWindow w) =

19+unitImageAndZeroWindow0 (UnitImage _ i) (EmptyWindow w) =

20− let p = pic_for_image i

20+ let p = picForImage i

21− ops = display_ops_for_pic p (region_for_window w)

21+ ops = displayOpsForPic p (regionForWindow w)

22− in display_ops_columns ops == 0 && display_ops_rows ops == 0

22+ in displayOpsColumns ops == 0 && displayOpsRows ops == 0

23−

23+

24−unit_image_and_zero_window_1 :: UnitImage -> EmptyWindow -> Bool

24+unitImageAndZeroWindow1 :: UnitImage -> EmptyWindow -> Bool

25−unit_image_and_zero_window_1 (UnitImage _ i) (EmptyWindow w) =

25+unitImageAndZeroWindow1 (UnitImage _ i) (EmptyWindow w) =

26− let p = pic_for_image i

26+ let p = picForImage i

27− ops = display_ops_for_pic p (region_for_window w)

27+ ops = displayOpsForPic p (regionForWindow w)

28− in ( span_ops_effected_rows ops == 0 ) && ( all_spans_have_width ops 0 )

28+ in ( spanOpsEffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )

29−

29+

30−horiz_span_image_and_zero_window_0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool

30+horizSpanImageAndZeroWindow0 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool

31−horiz_span_image_and_zero_window_0 (SingleRowSingleAttrImage { row_image = i }) (EmptyWindow w) =

31+horizSpanImageAndZeroWindow0 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =

32− let p = pic_for_image i

32+ let p = picForImage i

33− ops = display_ops_for_pic p (region_for_window w)

33+ ops = displayOpsForPic p (regionForWindow w)

34− in display_ops_columns ops == 0 && display_ops_rows ops == 0

34+ in displayOpsColumns ops == 0 && displayOpsRows ops == 0

35−

35+

36−horiz_span_image_and_zero_window_1 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool

36+horizSpanImageAndZeroWindow1 :: SingleRowSingleAttrImage -> EmptyWindow -> Bool

37−horiz_span_image_and_zero_window_1 (SingleRowSingleAttrImage { row_image = i }) (EmptyWindow w) =

37+horizSpanImageAndZeroWindow1 (SingleRowSingleAttrImage { rowImage = i }) (EmptyWindow w) =

38− let p = pic_for_image i

38+ let p = picForImage i

39− ops = display_ops_for_pic p (region_for_window w)

39+ ops = displayOpsForPic p (regionForWindow w)

40− in ( span_ops_effected_rows ops == 0 ) && ( all_spans_have_width ops 0 )

40+ in ( spanOpsEffectedRows ops == 0 ) && ( allSpansHaveWidth ops 0 )

41−

41+

42−horiz_span_image_and_equal_window_0 :: SingleRowSingleAttrImage -> Result

42+horizSpanImageAndEqualWindow0 :: SingleRowSingleAttrImage -> Result

43−horiz_span_image_and_equal_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) =

43+horizSpanImageAndEqualWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =

44− let p = pic_for_image i

44+ let p = picForImage i

45 w = MockWindow c 1

46− ops = display_ops_for_pic p (region_for_window w)

46+ ops = displayOpsForPic p (regionForWindow w)

47− in verify_all_spans_have_width i ops c

47+ in verifyAllSpansHaveWidth i ops c

49−horiz_span_image_and_equal_window_1 :: SingleRowSingleAttrImage -> Bool

49+horizSpanImageAndEqualWindow1 :: SingleRowSingleAttrImage -> Bool

50−horiz_span_image_and_equal_window_1 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) =

50+horizSpanImageAndEqualWindow1 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =

51− let p = pic_for_image i

51+ let p = picForImage i

52 w = MockWindow c 1

53− ops = display_ops_for_pic p (region_for_window w)

53+ ops = displayOpsForPic p (regionForWindow w)

54− in span_ops_effected_rows ops == 1

54+ in spanOpsEffectedRows ops == 1

55−

55+

56−horiz_span_image_and_lesser_window_0 :: SingleRowSingleAttrImage -> Result

56+horizSpanImageAndLesserWindow0 :: SingleRowSingleAttrImage -> Result

57−horiz_span_image_and_lesser_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) =

57+horizSpanImageAndLesserWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =

58− let p = pic_for_image i

58+ let p = picForImage i

59− lesser_width = c `div` 2

59+ lesserWidth = c `div` 2

60− w = MockWindow lesser_width 1

60+ w = MockWindow lesserWidth 1

61− ops = display_ops_for_pic p (region_for_window w)

61+ ops = displayOpsForPic p (regionForWindow w)

62− in verify_all_spans_have_width i ops lesser_width

62+ in verifyAllSpansHaveWidth i ops lesserWidth

63−

63+

64−single_attr_single_span_stack_cropped_0 :: SingleAttrSingleSpanStack -> Result

64+singleAttrSingleSpanStackCropped0 :: SingleAttrSingleSpanStack -> Result

65−single_attr_single_span_stack_cropped_0 stack =

65+singleAttrSingleSpanStackCropped0 stack =

66− let p = pic_for_image (stack_image stack)

66+ let p = picForImage (stackImage stack)

67− w = MockWindow (stack_width stack `div` 2) (stack_height stack)

67+ w = MockWindow (stackWidth stack `div` 2) (stackHeight stack)

68− ops = display_ops_for_pic p (region_for_window w)

68+ ops = displayOpsForPic p (regionForWindow w)

69− in verify_all_spans_have_width (stack_image stack) ops (stack_width stack `div` 2)

69+ in verifyAllSpansHaveWidth (stackImage stack) ops (stackWidth stack `div` 2)

70−

70+

71−single_attr_single_span_stack_cropped_1 :: SingleAttrSingleSpanStack -> Bool

71+singleAttrSingleSpanStackCropped1 :: SingleAttrSingleSpanStack -> Bool

72−single_attr_single_span_stack_cropped_1 stack =

72+singleAttrSingleSpanStackCropped1 stack =

73− let p = pic_for_image (stack_image stack)

73+ let p = picForImage (stackImage stack)

74− expected_row_count = stack_height stack `div` 2

74+ expectedRowCount = stackHeight stack `div` 2

75− w = MockWindow (stack_width stack) expected_row_count

75+ w = MockWindow (stackWidth stack) expectedRowCount

76− ops = display_ops_for_pic p (region_for_window w)

76+ ops = displayOpsForPic p (regionForWindow w)

77− actual_row_count = span_ops_effected_rows ops

77+ actualRowCount = spanOpsEffectedRows ops

78− in expected_row_count == actual_row_count

78+ in expectedRowCount == actualRowCount

79−

79+

80−single_attr_single_span_stack_cropped_2 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result

80+singleAttrSingleSpanStackCropped2 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result

81−single_attr_single_span_stack_cropped_2 stack_0 stack_1 =

81+singleAttrSingleSpanStackCropped2 stack0 stack_1 =

82− let p = pic_for_image (stack_image stack_0 <|> stack_image stack_1)

82+ let p = picForImage (stackImage stack0 <|> stackImage stack_1)

83− w = MockWindow (stack_width stack_0) (image_height (pic_image p))

83+ w = MockWindow (stackWidth stack0) (imageHeight (picImage p))

84− ops = display_ops_for_pic p (region_for_window w)

84+ ops = displayOpsForPic p (regionForWindow w)

85− in verify_all_spans_have_width (pic_image p) ops (stack_width stack_0)

85+ in verifyAllSpansHaveWidth (picImage p) ops (stackWidth stack0)

86−

86+

87−single_attr_single_span_stack_cropped_3 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool

87+singleAttrSingleSpanStackCropped3 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool

88−single_attr_single_span_stack_cropped_3 stack_0 stack_1 =

88+singleAttrSingleSpanStackCropped3 stack0 stack_1 =

89− let p = pic_for_image (stack_image stack_0 <|> stack_image stack_1)

89+ let p = picForImage (stackImage stack0 <|> stackImage stack_1)

90− w = MockWindow (image_width (pic_image p)) expected_row_count

90+ w = MockWindow (imageWidth (picImage p)) expectedRowCount

91− ops = display_ops_for_pic p (region_for_window w)

91+ ops = displayOpsForPic p (regionForWindow w)

92− expected_row_count = image_height (pic_image p) `div` 2

92+ expectedRowCount = imageHeight (picImage p) `div` 2

93− actual_row_count = span_ops_effected_rows ops

93+ actualRowCount = spanOpsEffectedRows ops

94− in expected_row_count == actual_row_count

94+ in expectedRowCount == actualRowCount

95−

95+

96−single_attr_single_span_stack_cropped_4 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result

96+singleAttrSingleSpanStackCropped4 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Result

97−single_attr_single_span_stack_cropped_4 stack_0 stack_1 =

97+singleAttrSingleSpanStackCropped4 stack0 stack_1 =

98− let p = pic_for_image (stack_image stack_0 <-> stack_image stack_1)

98+ let p = picForImage (stackImage stack0 <-> stackImage stack_1)

99− w = MockWindow expected_width (image_height (pic_image p))

99+ w = MockWindow expectedWidth (imageHeight (picImage p))

100− ops = display_ops_for_pic p (region_for_window w)

100+ ops = displayOpsForPic p (regionForWindow w)

101− expected_width = image_width (pic_image p) `div` 2

101+ expectedWidth = imageWidth (picImage p) `div` 2

102− in verify_all_spans_have_width (pic_image p) ops expected_width

102+ in verifyAllSpansHaveWidth (picImage p) ops expectedWidth

103−

103+

104−single_attr_single_span_stack_cropped_5 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool

104+singleAttrSingleSpanStackCropped5 :: SingleAttrSingleSpanStack -> SingleAttrSingleSpanStack -> Bool

105−single_attr_single_span_stack_cropped_5 stack_0 stack_1 =

105+singleAttrSingleSpanStackCropped5 stack0 stack_1 =

106− let p = pic_for_image (stack_image stack_0 <-> stack_image stack_1)

106+ let p = picForImage (stackImage stack0 <-> stackImage stack_1)

107− w = MockWindow (image_width (pic_image p)) (stack_height stack_0)

107+ w = MockWindow (imageWidth (picImage p)) (stackHeight stack0)

108− ops = display_ops_for_pic p (region_for_window w)

108+ ops = displayOpsForPic p (regionForWindow w)

109− expected_row_count = stack_height stack_0

109+ expectedRowCount = stackHeight stack0

110− actual_row_count = span_ops_effected_rows ops

110+ actualRowCount = spanOpsEffectedRows ops

111− in expected_row_count == actual_row_count

111+ in expectedRowCount == actualRowCount

112−

112+

113−horiz_span_image_and_greater_window_0 :: SingleRowSingleAttrImage -> Result

113+horizSpanImageAndGreaterWindow0 :: SingleRowSingleAttrImage -> Result

114−horiz_span_image_and_greater_window_0 (SingleRowSingleAttrImage { row_image = i, expected_columns = c }) =

114+horizSpanImageAndGreaterWindow0 (SingleRowSingleAttrImage { rowImage = i, expectedColumns = c }) =

115− let p = pic_for_image i

115+ let p = picForImage i

116 -- SingleRowSingleAttrImage always has width >= 1

117− greater_width = c * 2

117+ greaterWidth = c * 2

118− w = MockWindow greater_width 1

118+ w = MockWindow greaterWidth 1

119− ops = display_ops_for_pic p (region_for_window w)

119+ ops = displayOpsForPic p (regionForWindow w)

120− in verify_all_spans_have_width i ops greater_width

120+ in verifyAllSpansHaveWidth i ops greaterWidth

121−

121+

122−arb_image_is_cropped :: DefaultImage -> MockWindow -> Bool

122+arbImageIsCropped :: DefaultImage -> MockWindow -> Bool

123−arb_image_is_cropped (DefaultImage image) win@(MockWindow w h) =

123+arbImageIsCropped (DefaultImage image) win@(MockWindow w h) =

124− let pic = pic_for_image image

124+ let pic = picForImage image

125− ops = display_ops_for_pic pic (region_for_window win)

125+ ops = displayOpsForPic pic (regionForWindow win)

126− in ( span_ops_effected_rows ops == h ) && ( all_spans_have_width ops w )

126+ in ( spanOpsEffectedRows ops == h ) && ( allSpansHaveWidth ops w )

127−

127+

128−span_ops_actually_fill_rows :: DefaultPic -> Bool

128+spanOpsActuallyFillRows :: DefaultPic -> Bool

129−span_ops_actually_fill_rows (DefaultPic pic win) =

129+spanOpsActuallyFillRows (DefaultPic pic win) =

130− let ops = display_ops_for_pic pic (region_for_window win)

130+ let ops = displayOpsForPic pic (regionForWindow win)

131− expected_row_count = region_height (region_for_window win)

131+ expectedRowCount = regionHeight (regionForWindow win)

132− actual_row_count = span_ops_effected_rows ops

132+ actualRowCount = spanOpsEffectedRows ops

133− in expected_row_count == actual_row_count

133+ in expectedRowCount == actualRowCount

134−

134+

135−span_ops_actually_fill_columns :: DefaultPic -> Bool

135+spanOpsActuallyFillColumns :: DefaultPic -> Bool

136−span_ops_actually_fill_columns (DefaultPic pic win) =

136+spanOpsActuallyFillColumns (DefaultPic pic win) =

137− let ops = display_ops_for_pic pic (region_for_window win)

137+ let ops = displayOpsForPic pic (regionForWindow win)

138− expected_column_count = region_width (region_for_window win)

138+ expectedColumnCount = regionWidth (regionForWindow win)

139− in all_spans_have_width ops expected_column_count

139+ in allSpansHaveWidth ops expectedColumnCount

140−

140+

141−first_span_op_sets_attr :: DefaultPic -> Bool

141+firstSpanOpSetsAttr :: DefaultPic -> Bool

142−first_span_op_sets_attr DefaultPic { default_pic = pic, default_win = win } =

142+firstSpanOpSetsAttr DefaultPic { defaultPic = pic, defaultWin = win } =

143− let ops = display_ops_for_pic pic (region_for_window win)

143+ let ops = displayOpsForPic pic (regionForWindow win)

144− in all ( is_attr_span_op . Vector.head ) ( Vector.toList ops )

144+ in all ( isAttrSpanOp . Vector.head ) ( Vector.toList ops )

145−

145+

146−single_attr_single_span_stack_op_coverage :: SingleAttrSingleSpanStack -> Result

146+singleAttrSingleSpanStackOpCoverage :: SingleAttrSingleSpanStack -> Result

147−single_attr_single_span_stack_op_coverage stack =

147+singleAttrSingleSpanStackOpCoverage stack =

148− let p = pic_for_image (stack_image stack)

148+ let p = picForImage (stackImage stack)

149− w = MockWindow (stack_width stack) (stack_height stack)

149+ w = MockWindow (stackWidth stack) (stackHeight stack)

150− ops = display_ops_for_pic p (region_for_window w)

150+ ops = displayOpsForPic p (regionForWindow w)

151− in verify_all_spans_have_width (stack_image stack) ops (stack_width stack)

151+ in verifyAllSpansHaveWidth (stackImage stack) ops (stackWidth stack)

152−

152+

153−image_coverage_matches_bounds :: Image -> Result

153+imageCoverageMatchesBounds :: Image -> Result

154−image_coverage_matches_bounds i =

154+imageCoverageMatchesBounds i =

155− let p = pic_for_image i

155+ let p = picForImage i

156− r = (image_width i,image_height i)

156+ r = (imageWidth i,imageHeight i)

157− ops = display_ops_for_pic p r

157+ ops = displayOpsForPic p r

158− in verify_all_spans_have_width i ops (image_width i)

158+ in verifyAllSpansHaveWidth i ops (imageWidth i)

159

160tests :: IO [Test]

161tests = return

162− [ verify "unit image is cropped when window size == (0,0) [0]" unit_image_and_zero_window_0

162+ [ verify "unit image is cropped when window size == (0,0) [0]" unitImageAndZeroWindow0

163− , verify "unit image is cropped when window size == (0,0) [1]" unit_image_and_zero_window_1

163+ , verify "unit image is cropped when window size == (0,0) [1]" unitImageAndZeroWindow1

164− , verify "horiz span image is cropped when window size == (0,0) [0]" horiz_span_image_and_zero_window_0

164+ , verify "horiz span image is cropped when window size == (0,0) [0]" horizSpanImageAndZeroWindow0

165− , verify "horiz span image is cropped when window size == (0,0) [1]" horiz_span_image_and_zero_window_1

165+ , verify "horiz span image is cropped when window size == (0,0) [1]" horizSpanImageAndZeroWindow1

166− , verify "horiz span image is not cropped when window size == size of image [width]" horiz_span_image_and_equal_window_0

166+ , verify "horiz span image is not cropped when window size == size of image [width]" horizSpanImageAndEqualWindow0

167− , verify "horiz span image is not cropped when window size == size of image [height]" horiz_span_image_and_equal_window_1

167+ , verify "horiz span image is not cropped when window size == size of image [height]" horizSpanImageAndEqualWindow1

168− , verify "horiz span image is not cropped when window size < size of image [width]" horiz_span_image_and_lesser_window_0

168+ , verify "horiz span image is not cropped when window size < size of image [width]" horizSpanImageAndLesserWindow0

169− , verify "horiz span image is not cropped when window size > size of image [width]" horiz_span_image_and_greater_window_0

169+ , verify "horiz span image is not cropped when window size > size of image [width]" horizSpanImageAndGreaterWindow0

170− , verify "first span op is always to set the text attribute" first_span_op_sets_attr

170+ , verify "first span op is always to set the text attribute" firstSpanOpSetsAttr

171 , verify "a stack of single attr text spans should define content for all the columns [output region == size of stack]"

172− single_attr_single_span_stack_op_coverage

172+ singleAttrSingleSpanStackOpCoverage

173 , verify "a single attr text span is cropped when window size < size of stack image [width]"

174− single_attr_single_span_stack_cropped_0

174+ singleAttrSingleSpanStackCropped0

175 , verify "a single attr text span is cropped when window size < size of stack image [height]"

176− single_attr_single_span_stack_cropped_1

176+ singleAttrSingleSpanStackCropped1

177 , verify "single attr text span <|> single attr text span display cropped. [width]"

178− single_attr_single_span_stack_cropped_2

178+ singleAttrSingleSpanStackCropped2

179 , verify "single attr text span <|> single attr text span display cropped. [height]"

180− single_attr_single_span_stack_cropped_3

180+ singleAttrSingleSpanStackCropped3

181 , verify "single attr text span <-> single attr text span display cropped. [width]"

182− single_attr_single_span_stack_cropped_4

182+ singleAttrSingleSpanStackCropped4

183 , verify "single attr text span <-> single attr text span display cropped. [height]"

184− single_attr_single_span_stack_cropped_5

184+ singleAttrSingleSpanStackCropped5

185 , verify "an arbitrary image when rendered to a window of the same size will cover the entire window"

186− image_coverage_matches_bounds

186+ imageCoverageMatchesBounds

187 ]

188

test/VerifyUsingMockInput.hs+119−119

@@ -37,11 +37,11 @@ import Test.SmallCheck.Series

37import Text.Printf

39-- processing a block of 16 chars is the largest I can do without taking too long to run the test.

40−max_block_size :: Int

40+maxBlockSize :: Int

41−max_block_size = 16

41+maxBlockSize = 16

43−max_table_size :: Int

43+maxTableSize :: Int

44−max_table_size = 28

44+maxTableSize = 28

46forEachOf :: (Show a, Testable m b) => [a] -> (a -> b) -> Property m

47forEachOf l = over (generate (\n -> take n l))

@@ -55,81 +55,81 @@ type InputSpec = [InputEvent]

56type ExpectedSpec = [Event]

58−synthesize_input :: InputSpec -> Fd -> IO ()

58+synthesizeInput :: InputSpec -> Fd -> IO ()

59−synthesize_input input out_handle = forM_ input f >> (void $ fdWrite out_handle "\xFFFD")

59+synthesizeInput input outHandle = forM_ input f >> (void $ fdWrite outHandle "\xFFFD")

60 where

61− f (Bytes str) = void $ fdWrite out_handle str

61+ f (Bytes str) = void $ fdWrite outHandle str

62 f (Delay t) = threadDelay t

64−min_detectable_delay :: Int

64+minDetectableDelay :: Int

65−min_detectable_delay = 4000

65+minDetectableDelay = 4000

67−min_timout :: Int

67+minTimout :: Int

68−min_timout = 4000000

68+minTimout = 4000000

70−test_key_delay :: Int

70+testKeyDelay :: Int

71−test_key_delay = min_detectable_delay * 4

71+testKeyDelay = minDetectableDelay * 4

73−test_esc_sample_delay :: Int

73+testEscSampleDelay :: Int

74−test_esc_sample_delay = min_detectable_delay * 2

74+testEscSampleDelay = minDetectableDelay * 2

76−gen_events_using_io_actions :: Int -> IO () -> IO () -> IO ()

76+genEventsUsingIoActions :: Int -> IO () -> IO () -> IO ()

77−gen_events_using_io_actions max_duration input_action output_action = do

77+genEventsUsingIoActions maxDuration inputAction outputAction = do

78− let max_duration' = max min_timout max_duration

78+ let maxDuration' = max minTimout maxDuration

79− read_complete <- newEmptyMVar

79+ readComplete <- newEmptyMVar

80− write_complete <- newEmptyMVar

80+ writeComplete <- newEmptyMVar

81− _ <- forkOS $ input_action `finally` putMVar write_complete ()

81+ _ <- forkOS $ inputAction `finally` putMVar writeComplete ()

82− _ <- forkOS $ output_action `finally` putMVar read_complete ()

82+ _ <- forkOS $ outputAction `finally` putMVar readComplete ()

83− Just () <- timeout max_duration' $ takeMVar write_complete

83+ Just () <- timeout maxDuration' $ takeMVar writeComplete

84− Just () <- timeout max_duration' $ takeMVar read_complete

84+ Just () <- timeout maxDuration' $ takeMVar readComplete

85 return ()

87−compare_events :: (Show a1, Show a, Eq a1) => a -> [a1] -> [a1] -> IO Bool

87+compareEvents :: (Show a1, Show a, Eq a1) => a -> [a1] -> [a1] -> IO Bool

88−compare_events input_spec expected_events out_events = compare_events' expected_events out_events

88+compareEvents inputSpec expectedEvents outEvents = compareEvents' expectedEvents outEvents

89 where

90− compare_events' [] [] = return True

90+ compareEvents' [] [] = return True

91− compare_events' [] out_events' = do

91+ compareEvents' [] outEvents' = do

92− printf "extra events %s\n" (show out_events') :: IO ()

92+ printf "extra events %s\n" (show outEvents') :: IO ()

93 return False

94− compare_events' expected_events' [] = do

94+ compareEvents' expectedEvents' [] = do

95− printf "events %s were not produced for input %s\n" (show expected_events') (show input_spec) :: IO ()

95+ printf "events %s were not produced for input %s\n" (show expectedEvents') (show inputSpec) :: IO ()

96− printf "expected events %s\n" (show expected_events) :: IO ()

96+ printf "expected events %s\n" (show expectedEvents) :: IO ()

97− printf "received events %s\n" (show out_events) :: IO ()

97+ printf "received events %s\n" (show outEvents) :: IO ()

98 return False

99− compare_events' (e : expected_events') (o : out_events')

99+ compareEvents' (e : expectedEvents') (o : outEvents')

100− | e == o = compare_events' expected_events' out_events'

100+ | e == o = compareEvents' expectedEvents' outEvents'

101 | otherwise = do

102− printf "%s expected not %s for input %s\n" (show e) (show o) (show input_spec) :: IO ()

102+ printf "%s expected not %s for input %s\n" (show e) (show o) (show inputSpec) :: IO ()

103− printf "expected events %s\n" (show expected_events) :: IO ()

103+ printf "expected events %s\n" (show expectedEvents) :: IO ()

104− printf "received events %s\n" (show out_events) :: IO ()

104+ printf "received events %s\n" (show outEvents) :: IO ()

105 return False

106

107−assert_events_from_syn_input :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool

107+assertEventsFromSynInput :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool

108−assert_events_from_syn_input table input_spec expected_events = do

108+assertEventsFromSynInput table inputSpec expectedEvents = do

109− let max_duration = sum [t | Delay t <- input_spec] + min_detectable_delay

109+ let maxDuration = sum [t | Delay t <- inputSpec] + minDetectableDelay

110− event_count = length expected_events

110+ event_count = length expectedEvents

111− (write_fd, read_fd) <- openPseudoTerminal

111+ (writeFd, readFd) <- openPseudoTerminal

112− (set_term_attr,_) <- attributeControl read_fd

112+ (setTermAttr,_) <- attributeControl readFd

113− set_term_attr

113+ setTermAttr

114− input <- initInputForFd def table read_fd

114+ input <- initInputForFd def table readFd

115− events_ref <- newIORef []

115+ eventsRef <- newIORef []

116− let write_wait_close = do

116+ let writeWaitClose = do

117− synthesize_input input_spec write_fd

117+ synthesizeInput inputSpec writeFd

118− threadDelay min_detectable_delay

118+ threadDelay minDetectableDelay

119− shutdown_input input

119+ shutdownInput input

120− threadDelay min_detectable_delay

120+ threadDelay minDetectableDelay

121− closeFd write_fd

121+ closeFd writeFd

122− closeFd read_fd

122+ closeFd readFd

123 -- drain output pipe

124− let read_events = read_loop event_count

124+ let readEvents = readLoop event_count

125− read_loop 0 = return ()

125+ readLoop 0 = return ()

126− read_loop n = do

126+ readLoop n = do

127− e <- readChan $ input^.event_channel

127+ e <- readChan $ input^.eventChannel

128− modifyIORef events_ref ((:) e)

128+ modifyIORef eventsRef ((:) e)

129− read_loop (n - 1)

129+ readLoop (n - 1)

130− gen_events_using_io_actions max_duration write_wait_close read_events

130+ genEventsUsingIoActions maxDuration writeWaitClose readEvents

131− out_events <- reverse <$> readIORef events_ref

131+ outEvents <- reverse <$> readIORef eventsRef

132− compare_events input_spec expected_events out_events

132+ compareEvents inputSpec expectedEvents outEvents

133

134newtype InputBlocksUsingTable event

135 = InputBlocksUsingTable ([(String,event)] -> [(String, event)])

@@ -139,74 +139,74 @@ instance Show (InputBlocksUsingTable event) where

139

140instance Monad m => Serial m (InputBlocksUsingTable event) where

141 series = do

142− n :: Int <- localDepth (const max_table_size) series

142+ n :: Int <- localDepth (const maxTableSize) series

143 return $ InputBlocksUsingTable $ \table -> concat (take n (selections table))

144 where

145 selections [] = []

146 selections (x:xs) = let z = selections xs in [x] : (z ++ map ((:) x) z)

147

148−verify_visible_syn_input_to_event :: Property IO

148+verifyVisibleSynInputToEvent :: Property IO

149−verify_visible_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do

149+verifyVisibleSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do

150− let table = visible_chars

150+ let table = visibleChars

151− input_seq = gen table

151+ inputSeq = gen table

152− events = map snd input_seq

152+ events = map snd inputSeq

153− keydowns = map (Bytes . fst) input_seq

153+ keydowns = map (Bytes . fst) inputSeq

154− input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]

154+ input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]

155− assert_events_from_syn_input universal_table input events

155+ assertEventsFromSynInput universalTable input events

156−

156+

157−verify_caps_syn_input_to_event :: Property IO

157+verifyCapsSynInputToEvent :: Property IO

158−verify_caps_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) ->

158+verifyCapsSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->

159− forEachOf terminals_of_interest $ \term_name -> monadic $ do

159+ forEachOf terminalsOfInterest $ \termName -> monadic $ do

160− term <- setupTerm term_name

160+ term <- setupTerm termName

161− let table = caps_classify_table term keys_from_caps_table

161+ let table = capsClassifyTable term keysFromCapsTable

162− input_seq = gen table

162+ inputSeq = gen table

163− events = map snd input_seq

163+ events = map snd inputSeq

164− keydowns = map (Bytes . fst) input_seq

164+ keydowns = map (Bytes . fst) inputSeq

165− input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]

165+ input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]

166− assert_events_from_syn_input table input events

166+ assertEventsFromSynInput table input events

167−

167+

168−verify_special_syn_input_to_event :: Property IO

168+verifySpecialSynInputToEvent :: Property IO

169−verify_special_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do

169+verifySpecialSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) -> monadic $ do

170− let table = special_support_keys

170+ let table = specialSupportKeys

171− input_seq = gen table

171+ inputSeq = gen table

172− events = map snd input_seq

172+ events = map snd inputSeq

173− keydowns = map (Bytes . fst) input_seq

173+ keydowns = map (Bytes . fst) inputSeq

174− input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]

174+ input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]

175− assert_events_from_syn_input universal_table input events

175+ assertEventsFromSynInput universalTable input events

176−

176+

177−verify_full_syn_input_to_event :: Property IO

177+verifyFullSynInputToEvent :: Property IO

178−verify_full_syn_input_to_event = forAll $ \(InputBlocksUsingTable gen) ->

178+verifyFullSynInputToEvent = forAll $ \(InputBlocksUsingTable gen) ->

179− forEachOf terminals_of_interest $ \term_name -> monadic $ do

179+ forEachOf terminalsOfInterest $ \termName -> monadic $ do

180− term <- setupTerm term_name

180+ term <- setupTerm termName

181− let table = classify_table_for_term term_name term

181+ let table = classifyTableForTerm termName term

182− input_seq = gen table

182+ inputSeq = gen table

183− events = map snd input_seq

183+ events = map snd inputSeq

184− keydowns = map (Bytes . fst) input_seq

184+ keydowns = map (Bytes . fst) inputSeq

185− input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]

185+ input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]

186− assert_events_from_syn_input table input events

186+ assertEventsFromSynInput table input events

187−

187+

188−verify_full_syn_input_to_event_2x :: Property IO

188+verifyFullSynInputToEvent_2x :: Property IO

189−verify_full_syn_input_to_event_2x = forAll $ \(InputBlocksUsingTable gen) ->

189+verifyFullSynInputToEvent_2x = forAll $ \(InputBlocksUsingTable gen) ->

190− forEachOf terminals_of_interest $ \term_name -> monadic $ do

190+ forEachOf terminalsOfInterest $ \termName -> monadic $ do

191− term <- setupTerm term_name

191+ term <- setupTerm termName

192− let table = classify_table_for_term term_name term

192+ let table = classifyTableForTerm termName term

193− input_seq = gen table

193+ inputSeq = gen table

194− events = concatMap ((\s -> [s,s]) . snd) input_seq

194+ events = concatMap ((\s -> [s,s]) . snd) inputSeq

195− keydowns = map (Bytes . (\s -> s ++ s) . fst) input_seq

195+ keydowns = map (Bytes . (\s -> s ++ s) . fst) inputSeq

196− input = intersperse (Delay test_key_delay) keydowns ++ [Delay test_key_delay]

196+ input = intersperse (Delay testKeyDelay) keydowns ++ [Delay testKeyDelay]

197− assert_events_from_syn_input table input events

197+ assertEventsFromSynInput table input events

198

199main :: IO ()

200main = defaultMain

201 [ testProperty "synthesized typing of single visible chars translates to expected events"

202− verify_visible_syn_input_to_event

202+ verifyVisibleSynInputToEvent

203 , testProperty "synthesized typing of keys from capabilities tables translates to expected events"

204− verify_caps_syn_input_to_event

204+ verifyCapsSynInputToEvent

205 , testProperty "synthesized typing of hard coded special keys translates to expected events"

206− verify_special_syn_input_to_event

206+ verifySpecialSynInputToEvent

207 , testProperty "synthesized typing of any key in the table translates to its paired event"

208− verify_full_syn_input_to_event

208+ verifyFullSynInputToEvent

209 , testProperty "synthesized typing of 2x any key in the table translates to 2x paired event"

210− verify_full_syn_input_to_event_2x

210+ verifyFullSynInputToEvent_2x

211 ]

212

test/VerifyUsingMockTerminal.hs+51−51

@@ -19,82 +19,82 @@ import qualified Data.String.UTF8 as UTF8

20import System.IO

22−unit_image_unit_bounds :: UnitImage -> Property

22+unitImageUnitBounds :: UnitImage -> Property

23−unit_image_unit_bounds (UnitImage _ i) = liftIOResult $ do

23+unitImageUnitBounds (UnitImage _ i) = liftIOResult $ do

24− (_,t) <- mock_terminal (1,1)

24+ (_,t) <- mockTerminal (1,1)

25− dc <- display_bounds t >>= display_context t

25+ dc <- displayBounds t >>= displayContext t

26− let pic = pic_for_image i

26+ let pic = picForImage i

27− output_picture dc pic

27+ outputPicture dc pic

28 return succeeded

30−unit_image_arb_bounds :: UnitImage -> MockWindow -> Property

30+unitImageArbBounds :: UnitImage -> MockWindow -> Property

31−unit_image_arb_bounds (UnitImage _ i) (MockWindow w h) = liftIOResult $ do

31+unitImageArbBounds (UnitImage _ i) (MockWindow w h) = liftIOResult $ do

32− (_,t) <- mock_terminal (w,h)

32+ (_,t) <- mockTerminal (w,h)

33− dc <- display_bounds t >>= display_context t

33+ dc <- displayBounds t >>= displayContext t

34− let pic = pic_for_image i

34+ let pic = picForImage i

35− output_picture dc pic

35+ outputPicture dc pic

36 return succeeded

38−single_T_row :: MockWindow -> Property

38+singleTRow :: MockWindow -> Property

39−single_T_row (MockWindow w h) = liftIOResult $ do

39+singleTRow (MockWindow w h) = liftIOResult $ do

40− (mock_data,t) <- mock_terminal (w,h)

40+ (mockData,t) <- mockTerminal (w,h)

41− dc <- display_bounds t >>= display_context t

41+ dc <- displayBounds t >>= displayContext t

42 -- create an image that contains just the character T repeated for a single row

43− let i = horiz_cat $ replicate (fromEnum w) (char def_attr 'T')

43+ let i = horizCat $ replicate (fromEnum w) (char defAttr 'T')

44− pic = (pic_for_image i) { pic_background = Background 'B' def_attr }

44+ pic = (picForImage i) { picBackground = Background 'B' defAttr }

45− output_picture dc pic

45+ outputPicture dc pic

46 -- The mock output string that represents the output bytes a single line containing the T

47 -- string: Followed by h - 1 lines of a change to the background attribute and then the

48 -- background character

49 let expected = "HD" ++ "MA" ++ replicate (fromEnum w) 'T'

50− ++ concat (replicate (fromEnum h - 1) $ "MA" ++ replicate (fromEnum w) 'B')

50+ ++ concat (replicate (fromEnum h - 1) $ "MA" ++ replicate (fromEnum w) 'B')

51− compare_mock_output mock_data expected

51+ compareMockOutput mockData expected

53−many_T_rows :: MockWindow -> Property

53+manyTRows :: MockWindow -> Property

54−many_T_rows (MockWindow w h) = liftIOResult $ do

54+manyTRows (MockWindow w h) = liftIOResult $ do

55− (mock_data, t) <- mock_terminal (w,h)

55+ (mockData, t) <- mockTerminal (w,h)

56− dc <- display_bounds t >>= display_context t

56+ dc <- displayBounds t >>= displayContext t

57 -- create an image that contains the character 'T' repeated for all the rows

58− let i = vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w) (char def_attr 'T')

58+ let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w) (char defAttr 'T')

59− pic = (pic_for_image i) { pic_background = Background 'B' def_attr }

59+ pic = (picForImage i) { picBackground = Background 'B' defAttr }

60− output_picture dc pic

60+ outputPicture dc pic

61 -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an

62 -- attribute change. 'A', followed by w 'T's

63 let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T')

64− compare_mock_output mock_data expected

64+ compareMockOutput mockData expected

66−many_T_rows_cropped_width :: MockWindow -> Property

66+manyTRowsCroppedWidth :: MockWindow -> Property

67−many_T_rows_cropped_width (MockWindow w h) = liftIOResult $ do

67+manyTRowsCroppedWidth (MockWindow w h) = liftIOResult $ do

68− (mock_data,t) <- mock_terminal (w,h)

68+ (mockData,t) <- mockTerminal (w,h)

69− dc <- display_bounds t >>= display_context t

69+ dc <- displayBounds t >>= displayContext t

70 -- create an image that contains the character 'T' repeated for all the rows

71− let i = vert_cat $ replicate (fromEnum h) $ horiz_cat $ replicate (fromEnum w * 2) (char def_attr 'T')

71+ let i = vertCat $ replicate (fromEnum h) $ horizCat $ replicate (fromEnum w * 2) (char defAttr 'T')

72− pic = (pic_for_image i) { pic_background = Background 'B' def_attr }

72+ pic = (picForImage i) { picBackground = Background 'B' defAttr }

73− output_picture dc pic

73+ outputPicture dc pic

74 -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an

75 -- attribute change. 'A', followed by w 'T's

76 let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T')

77− compare_mock_output mock_data expected

77+ compareMockOutput mockData expected

79−many_T_rows_cropped_height :: MockWindow -> Property

79+manyTRowsCroppedHeight :: MockWindow -> Property

80−many_T_rows_cropped_height (MockWindow w h) = liftIOResult $ do

80+manyTRowsCroppedHeight (MockWindow w h) = liftIOResult $ do

81− (mock_data,t) <- mock_terminal (w,h)

81+ (mockData,t) <- mockTerminal (w,h)

82− dc <- display_bounds t >>= display_context t

82+ dc <- displayBounds t >>= displayContext t

83 -- create an image that contains the character 'T' repeated for all the rows

84− let i = vert_cat $ replicate (fromEnum h * 2) $ horiz_cat $ replicate (fromEnum w) (char def_attr 'T')

84+ let i = vertCat $ replicate (fromEnum h * 2) $ horizCat $ replicate (fromEnum w) (char defAttr 'T')

85− pic = (pic_for_image i) { pic_background = Background 'B' def_attr }

85+ pic = (picForImage i) { picBackground = Background 'B' defAttr }

86− output_picture dc pic

86+ outputPicture dc pic

87 -- The UTF8 string that represents the output bytes is h repeats of a move, 'M', followed by an

88 -- attribute change. 'A', followed by w count 'T's

89 let expected = "HD" ++ concat (replicate (fromEnum h) $ "MA" ++ replicate (fromEnum w) 'T')

90− compare_mock_output mock_data expected

90+ compareMockOutput mockData expected

92tests :: IO [Test]

93−tests = return [ verify "unit_image_unit_bounds" unit_image_unit_bounds

93+tests = return [ verify "unitImageUnitBounds" unitImageUnitBounds

94− , verify "unit_image_arb_bounds" unit_image_arb_bounds

94+ , verify "unitImageArbBounds" unitImageArbBounds

95− , verify "single_T_row" single_T_row

95+ , verify "singleTRow" singleTRow

96− , verify "many_T_rows" many_T_rows

96+ , verify "manyTRows" manyTRows

97− , verify "many_T_rows_cropped_width" many_T_rows_cropped_width

97+ , verify "manyTRowsCroppedWidth" manyTRowsCroppedWidth

98− , verify "many_T_rows_cropped_height" many_T_rows_cropped_height

98+ , verify "manyTRowsCroppedHeight" manyTRowsCroppedHeight

99 ]

100

test/VerifyUtf8Width.hs+13−13

@@ -5,24 +5,24 @@ import Graphics.Text.Width

5import Graphics.Vty.Attributes

6import Graphics.Vty.Picture

8−sw_is_1_column :: SingleColumnChar -> Bool

8+swIs1Column :: SingleColumnChar -> Bool

9−sw_is_1_column (SingleColumnChar c) = image_width (char def_attr c) == 1

9+swIs1Column (SingleColumnChar c) = imageWidth (char defAttr c) == 1

11−dw_is_2_column :: DoubleColumnChar -> Bool

11+dwIs2Column :: DoubleColumnChar -> Bool

12−dw_is_2_column (DoubleColumnChar c) = image_width (char def_attr c) == 2

12+dwIs2Column (DoubleColumnChar c) = imageWidth (char defAttr c) == 2

14−dc_string_is_even :: NonEmptyList DoubleColumnChar -> Bool

14+dcStringIsEven :: NonEmptyList DoubleColumnChar -> Bool

15−dc_string_is_even (NonEmpty dw_list) =

15+dcStringIsEven (NonEmpty dw_list) =

16− even $ safe_wcswidth [ c | DoubleColumnChar c <- dw_list ]

16+ even $ safeWcswidth [ c | DoubleColumnChar c <- dw_list ]

18−safe_wcwidth_for_control_chars :: Bool

18+safeWcwidthForControlChars :: Bool

19−safe_wcwidth_for_control_chars = 0 == safe_wcwidth '\NUL'

19+safeWcwidthForControlChars = 0 == safeWcwidth '\NUL'

21tests :: IO [Test]

22tests = return

23− [ verify "sw_is_1_column" sw_is_1_column

23+ [ verify "swIs1Column" swIs1Column

24− , verify "dw_is_2_column" dw_is_2_column

24+ , verify "dwIs2Column" dwIs2Column

25− , verify "a string of double characters is an even width" dc_string_is_even

25+ , verify "a string of double characters is an even width" dcStringIsEven

26− , verify "safe_wcwidth provides a width of 0 for chars without widths" safe_wcwidth_for_control_chars

26+ , verify "safeWcwidth provides a width of 0 for chars without widths" safeWcwidthForControlChars

27 ]

test/benchmark.hs+21−21

@@ -20,11 +20,11 @@ import Verify

21main = do

22 args <- getArgs

23− let benches = [ ("no-diff-opt-0", BenchNoDiffOpt.bench_0)

23+ let benches = [ ("no-diff-opt-0", BenchNoDiffOpt.bench0)

24− , ("render-char-0", BenchRenderChar.bench_0)

24+ , ("render-char-0", BenchRenderChar.bench0)

25− , ("render-char-1", BenchRenderChar.bench_1)

25+ , ("render-char-1", BenchRenderChar.bench1)

26− , ("vertical-scroll-0", BenchVerticalScroll.bench_0)

26+ , ("vertical-scroll-0", BenchVerticalScroll.bench0)

27− , ("image-fuzz-0", BenchImageFuzz.bench_0) ]

27+ , ("image-fuzz-0", BenchImageFuzz.bench0) ]

28 help = forM_ benches $ \(b,_) -> putStrLn $ "--" ++ b

29 case args of

30 ["--help"] -> help

@@ -34,23 +34,23 @@ main = do

34 then map (drop 2) args

35 else map fst benches

36 -- drop the dash-dash "--"

37− results <- forM args' $ \b_name -> do

37+ results <- forM args' $ \bName -> do

38− case lookup b_name benches of

38+ case lookup bName benches of

39− Just b -> bench b_name b

39+ Just b -> bench bName b

40− Nothing -> fail $ "No benchmark named " ++ b_name

40+ Nothing -> fail $ "No benchmark named " ++ bName

41 print results

42 return ()

44−bench b_name b = do

44+bench bName b = do

45− putStrLn $ "starting " ++ b_name

45+ putStrLn $ "starting " ++ bName

46− Bench b_data_gen b_proc <- b

46+ Bench bDataGen bProc <- b

47− b_data <- b_data_gen

47+ bData <- bDataGen

48− start_times <- b_data `deepseq` getProcessTimes

48+ startTimes <- bData `deepseq` getProcessTimes

49− b_proc b_data

49+ bProc bData

50− end_times <- getProcessTimes

50+ endTimes <- getProcessTimes

51− let user_time = userTime end_times - userTime start_times

51+ let ut = userTime endTimes - userTime startTimes

52− system_time = systemTime end_times - systemTime start_times

52+ st = systemTime endTimes - systemTime startTimes

53− putStrLn $ "user time: " ++ show user_time

53+ putStrLn $ "user time: " ++ show ut

54− putStrLn $ "system time: " ++ show system_time

54+ putStrLn $ "system time: " ++ show st

55− return (b_name, user_time, system_time)

55+ return (bName, ut, st)

test/interactive_terminal_test.hs+557−557

@@ -25,11 +25,11 @@ import qualified System.Environment as Env

25import System.IO ( hFlush, hPutStr, hPutBuf, stdout )

27main = do

28− print_intro

28+ printIntro

30−output_file_path = "test_results.list"

30+outputFilePath = "test_results.list"

32−print_intro = do

32+printIntro = do

33 putStr $ [s|

34This is an interactive verification program for the terminal input and output

35support of the VTY library. This will ask a series of questions about what you

@@ -37,7 +37,7 @@ see on screen. The goal is to verify that VTY's output and input support

37performs as expected with your terminal.

39This program produces a file named

40− |] ++ output_file_path ++ [s|

40+ |] ++ outputFilePath ++ [s|

41in the current directory that contains the results for each test assertion. This

42can be emailed to coreyoconnor@gmail.com and used by the VTY authors to improve

43support for your terminal. No personal information is contained in the report.

@@ -72,35 +72,35 @@ with the test_results.list file pasted into the issue. The issue summary can

72mention the specific tests that failed or just say "interactive terminal test

73failure".

74|]

75− wait_for_return

75+ waitForReturn

76− results <- do_test_menu 1

76+ results <- doTestMenu 1

77− env_attributes <- mapM ( \env_name -> Control.Exception.catch ( Env.getEnv env_name >>= return . (,) env_name )

77+ envAttributes <- mapM ( \env_name -> Control.Exception.catch ( Env.getEnv env_name >>= return . (,) env_name )

78 ( \ (_ :: SomeException) -> return (env_name, "") )

79− )

79+ )

80− [ "TERM", "COLORTERM", "LANG", "TERM_PROGRAM", "XTERM_VERSION" ]

80+ [ "TERM", "COLORTERM", "LANG", "TERM_PROGRAM", "XTERM_VERSION" ]

81− t <- output_for_current_terminal

81+ t <- outputForCurrentTerminal

82− let results_txt = show env_attributes ++ "\n"

82+ let resultsTxt = show envAttributes ++ "\n"

83− ++ terminal_ID t ++ "\n"

83+ ++ terminalID t ++ "\n"

84− ++ show results ++ "\n"

84+ ++ show results ++ "\n"

85− release_terminal t

85+ releaseTerminal t

86− writeFile output_file_path results_txt

86+ writeFile outputFilePath resultsTxt

87−

87+

88−wait_for_return = do

88+waitForReturn = do

89 putStr "\n(press return to continue)"

90 hFlush stdout

91 getLine

93−test_menu :: [(String, Test)]

93+testMenu :: [(String, Test)]

94−test_menu = zip (map show [1..]) all_tests

94+testMenu = zip (map show [1..]) allTests

96−do_test_menu :: Int -> IO [(String, Bool)]

96+doTestMenu :: Int -> IO [(String, Bool)]

97−do_test_menu next_ID

97+doTestMenu nextID

98− | next_ID > length all_tests = do

98+ | nextID > length allTests = do

99− putStrLn $ "Done! Please email the " ++ output_file_path ++ " file to coreyoconnor@gmail.com"

99+ putStrLn $ "Done! Please email the " ++ outputFilePath ++ " file to coreyoconnor@gmail.com"

100 return []

101 | otherwise = do

102− display_test_menu

102+ displayTestMenu

103− putStrLn $ "Press return to start with #" ++ show next_ID ++ "."

103+ putStrLn $ "Press return to start with #" ++ show nextID ++ "."

104 putStrLn "Enter a test number to perform only that test."

105 putStrLn "q (or control-C) to quit."

106 putStr "> "

@@ -109,98 +109,98 @@ do_test_menu next_ID

109 case s of

110 "q" -> return mempty

111 "" -> do

112− r <- run_test $ show next_ID

112+ r <- runTest $ show nextID

113− rs <- do_test_menu ( next_ID + 1 )

113+ rs <- doTestMenu ( nextID + 1 )

114 return $ r : rs

115− i | isJust ( lookup i test_menu ) -> do

115+ i | isJust ( lookup i testMenu ) -> do

116− r <- run_test i

116+ r <- runTest i

117− rs <- do_test_menu ( read i + 1 )

117+ rs <- doTestMenu ( read i + 1 )

118 return $ r : rs

119 where

120− display_test_menu

120+ displayTestMenu

121− = mapM_ display_test_menu' test_menu

121+ = mapM_ displayTestMenu' testMenu

122− display_test_menu' ( i, t )

122+ displayTestMenu' ( i, t )

123− = putStrLn $ ( if i == show next_ID

123+ = putStrLn $ ( if i == show nextID

124 then "> "

125 else " "

126− ) ++ i ++ ". " ++ test_name t

126+ ) ++ i ++ ". " ++ testName t

127−

127+

128−run_test :: String -> IO (String, Bool)

128+runTest :: String -> IO (String, Bool)

129−run_test i = do

129+runTest i = do

130− let t = fromJust $ lookup i test_menu

130+ let t = fromJust $ lookup i testMenu

131− print_summary t

131+ printSummary t

132− wait_for_return

132+ waitForReturn

133− test_action t

133+ testAction t

134− r <- confirm_results t

134+ r <- confirmResults t

135− return (test_ID t, r)

135+ return (testID t, r)

136−

136+

137−default_success_confirm_results = do

137+defaultSuccessConfirmResults = do

138 putStr "\n"

139 putStr "[Y/n] "

140 hFlush stdout

141 r <- getLine

142 case r of

143− "" -> return True

143+ "" -> return True

144 "y" -> return True

145 "Y" -> return True

146 "n" -> return False

147

148data Test = Test

149− { test_name :: String

149+ { testName :: String

150− , test_ID :: String

150+ , testID :: String

151− , test_action :: IO ()

151+ , testAction :: IO ()

152− , print_summary :: IO ()

152+ , printSummary :: IO ()

153− , confirm_results :: IO Bool

153+ , confirmResults :: IO Bool

154 }

155

156−all_tests

156+allTests

157− = [ reserve_output_test

157+ = [ reserveOutputTest

158− , display_bounds_test_0

158+ , displayBoundsTest0

159− , display_bounds_test_1

159+ , displayBoundsTest1

160− , display_bounds_test_2

160+ , displayBoundsTest2

161− , display_bounds_test_3

161+ , displayBoundsTest3

162− , unicode_single_width_0

162+ , unicodeSingleWidth0

163− , unicode_single_width_1

163+ , unicodeSingleWidth1

164− , unicode_double_width_0

164+ , unicodeDoubleWidth0

165− , unicode_double_width_1

165+ , unicodeDoubleWidth1

166− , attributes_test_0

166+ , attributesTest0

167− , attributes_test_1

167+ , attributesTest1

168− , attributes_test_2

168+ , attributesTest2

169− , attributes_test_3

169+ , attributesTest3

170− , attributes_test_4

170+ , attributesTest4

171− , attributes_test_5

171+ , attributesTest5

172− , inline_test_0

172+ , inlineTest0

173− , inline_test_1

173+ , inlineTest1

174− , inline_test_2

174+ , inlineTest2

175− , cursor_hide_test_0

175+ , cursorHideTest0

176− , vert_crop_test_0

176+ , vertCropTest0

177− , vert_crop_test_1

177+ , vertCropTest1

178− , vert_crop_test_2

178+ , vertCropTest2

179− , vert_crop_test_3

179+ , vertCropTest3

180− , horiz_crop_test_0

180+ , horizCropTest0

181− , horiz_crop_test_1

181+ , horizCropTest1

182− , horiz_crop_test_2

182+ , horizCropTest2

183− , horiz_crop_test_3

183+ , horizCropTest3

184− , layer_0

184+ , layer0

185− , layer_1

185+ , layer1

186 ]

187

188−reserve_output_test = Test

188+reserveOutputTest = Test

189− { test_name = "Initialize and reserve terminal output then restore previous state."

189+ { testName = "Initialize and reserve terminal output then restore previous state."

190− , test_ID = "reserve_output_test"

190+ , testID = "reserveOutputTest"

191− , test_action = do

191+ , testAction = do

192− t <- output_for_current_terminal

192+ t <- outputForCurrentTerminal

193− reserve_display t

193+ reserveDisplay t

194 putStrLn "Line 1"

195 putStrLn "Line 2"

196 putStrLn "Line 3"

197 putStrLn "Line 4 (press return)"

198 hFlush stdout

199 getLine

200− release_display t

200+ releaseDisplay t

201− release_terminal t

201+ releaseTerminal t

202 return ()

203− , print_summary = do

203+ , printSummary = do

204 putStr $ [s|

205Once return is pressed:

206 0. The screen will be cleared.

@@ -211,123 +211,123 @@ After return is pressed for the second time this test then:

211 * The screen containing the test summary should be restored;

212 * The cursor is visible.

213|]

214− , confirm_results = do

214+ , confirmResults = do

215 putStr $ [s|

216Did the test output match the description?

217|]

218− default_success_confirm_results

218+ defaultSuccessConfirmResults

219 }

220

221−display_bounds_test_0 = Test

221+displayBoundsTest0 = Test

222− { test_name = "Verify display bounds are correct test 0: Using spaces."

222+ { testName = "Verify display bounds are correct test 0: Using spaces."

223− , test_ID = "display_bounds_test_0"

223+ , testID = "displayBoundsTest0"

224− , test_action = do

224+ , testAction = do

225− t <- output_for_current_terminal

225+ t <- outputForCurrentTerminal

226− reserve_display t

226+ reserveDisplay t

227− (w,h) <- display_bounds t

227+ (w,h) <- displayBounds t

228− let row_0 = replicate (fromEnum w) 'X' ++ "\n"

228+ let row0 = replicate (fromEnum w) 'X' ++ "\n"

229− row_h = replicate (fromEnum w - 1) 'X'

229+ rowH = replicate (fromEnum w - 1) 'X'

230− row_n = "X" ++ replicate (fromEnum w - 2) ' ' ++ "X\n"

230+ rowN = "X" ++ replicate (fromEnum w - 2) ' ' ++ "X\n"

231− image = row_0 ++ (concat $ replicate (fromEnum h - 2) row_n) ++ row_h

231+ image = row0 ++ (concat $ replicate (fromEnum h - 2) rowN) ++ rowH

232 putStr image

233 hFlush stdout

234 getLine

235− release_display t

235+ releaseDisplay t

236− release_terminal t

236+ releaseTerminal t

237 return ()

238− , print_summary = display_bounds_test_summary True

238+ , printSummary = displayBoundsTestSummary True

239− , confirm_results = generic_output_match_confirm

239+ , confirmResults = genericOutputMatchConfirm

240 }

241

242−display_bounds_test_1 = Test

242+displayBoundsTest1 = Test

243− { test_name = "Verify display bounds are correct test 0: Using cursor movement."

243+ { testName = "Verify display bounds are correct test 0: Using cursor movement."

244− , test_ID = "display_bounds_test_1"

244+ , testID = "displayBoundsTest1"

245− , test_action = do

245+ , testAction = do

246− t <- output_for_current_terminal

246+ t <- outputForCurrentTerminal

247− reserve_display t

247+ reserveDisplay t

248− (w,h) <- display_bounds t

248+ (w,h) <- displayBounds t

249− set_cursor_pos t 0 0

249+ setCursorPos t 0 0

250− let row_0 = replicate (fromEnum w) 'X' ++ "\n"

250+ let row0 = replicate (fromEnum w) 'X' ++ "\n"

251− putStr row_0

251+ putStr row0

252 forM_ [1 .. h - 2] $ \y -> do

253− set_cursor_pos t 0 y

253+ setCursorPos t 0 y

254 putStr "X"

255 hFlush stdout

256− set_cursor_pos t (w - 1) y

256+ setCursorPos t (w - 1) y

257 putStr "X"

258 hFlush stdout

259− set_cursor_pos t 0 (h - 1)

259+ setCursorPos t 0 (h - 1)

260− let row_h = replicate (fromEnum w - 1) 'X'

260+ let rowH = replicate (fromEnum w - 1) 'X'

261− putStr row_h

261+ putStr rowH

262 hFlush stdout

263 getLine

264− release_display t

264+ releaseDisplay t

265− release_terminal t

265+ releaseTerminal t

266 return ()

267− , print_summary = display_bounds_test_summary True

267+ , printSummary = displayBoundsTestSummary True

268− , confirm_results = generic_output_match_confirm

268+ , confirmResults = genericOutputMatchConfirm

269 }

270

271−display_bounds_test_2 = Test

271+displayBoundsTest2 = Test

272− { test_name = "Verify display bounds are correct test 0: Using Image ops."

272+ { testName = "Verify display bounds are correct test 0: Using Image ops."

273− , test_ID = "display_bounds_test_2"

273+ , testID = "displayBoundsTest2"

274− , test_action = do

274+ , testAction = do

275− t <- output_for_current_terminal

275+ t <- outputForCurrentTerminal

276− reserve_display t

276+ reserveDisplay t

277− bounds@(w,h) <- display_bounds t

277+ bounds@(w,h) <- displayBounds t

278− let first_row = horiz_cat $ replicate (fromEnum w) (char def_attr 'X')

278+ let firstRow = horizCat $ replicate (fromEnum w) (char defAttr 'X')

279− middle_rows = vert_cat $ replicate (fromEnum h - 2) middle_row

279+ middleRows = vertCat $ replicate (fromEnum h - 2) middleRow

280− middle_row = (char def_attr 'X') <|> background_fill (w - 2) 1 <|> (char def_attr 'X')

280+ middleRow = (char defAttr 'X') <|> backgroundFill (w - 2) 1 <|> (char defAttr 'X')

281− end_row = first_row

281+ endRow = firstRow

282− image = first_row <-> middle_rows <-> end_row

282+ image = firstRow <-> middleRows <-> endRow

283− pic = (pic_for_image image) { pic_cursor = Cursor (w - 1) (h - 1) }

283+ pic = (picForImage image) { picCursor = Cursor (w - 1) (h - 1) }

284− d <- display_context t bounds

284+ d <- displayContext t bounds

285− output_picture d pic

285+ outputPicture d pic

286 getLine

287− release_display t

287+ releaseDisplay t

288− release_terminal t

288+ releaseTerminal t

289 return ()

290− , print_summary = display_bounds_test_summary True

290+ , printSummary = displayBoundsTestSummary True

291− , confirm_results = generic_output_match_confirm

291+ , confirmResults = genericOutputMatchConfirm

292 }

293

294−display_bounds_test_3 = Test

294+displayBoundsTest3 = Test

295− { test_name = "Verify display bounds are correct test 0: Hide cursor; Set cursor pos."

295+ { testName = "Verify display bounds are correct test 0: Hide cursor; Set cursor pos."

296− , test_ID = "display_bounds_test_3"

296+ , testID = "displayBoundsTest3"

297− , test_action = do

297+ , testAction = do

298− t <- output_for_current_terminal

298+ t <- outputForCurrentTerminal

299− reserve_display t

299+ reserveDisplay t

300− (w,h) <- display_bounds t

300+ (w,h) <- displayBounds t

301− hide_cursor t

301+ hideCursor t

302− set_cursor_pos t 0 0

302+ setCursorPos t 0 0

303− let row_0 = replicate (fromEnum w) 'X'

303+ let row0 = replicate (fromEnum w) 'X'

304− putStrLn row_0

304+ putStrLn row0

305 forM_ [1 .. h - 2] $ \y -> do

306− set_cursor_pos t 0 y

306+ setCursorPos t 0 y

307 putStr "X"

308 hFlush stdout

309− set_cursor_pos t (w - 1) y

309+ setCursorPos t (w - 1) y

310 putStr "X"

311 hFlush stdout

312− set_cursor_pos t 0 (h - 1)

312+ setCursorPos t 0 (h - 1)

313− let row_h = row_0

313+ let rowH = row0

314− putStr row_h

314+ putStr rowH

315 hFlush stdout

316 getLine

317− show_cursor t

317+ showCursor t

318− release_display t

318+ releaseDisplay t

319− release_terminal t

319+ releaseTerminal t

320 return ()

321− , print_summary = display_bounds_test_summary False

321+ , printSummary = displayBoundsTestSummary False

322− , confirm_results = generic_output_match_confirm

322+ , confirmResults = genericOutputMatchConfirm

323 }

324

325−display_bounds_test_summary has_cursor = do

325+displayBoundsTestSummary hasCursor = do

326 putStr $ [s|

327Once return is pressed:

328 0. The screen will be cleared.

329|]

330− if has_cursor

330+ if hasCursor

331 then putStr " 1. The cursor will be visible."

332 else putStr " 1. The cursor will NOT be visible."

333 putStr [s|

@@ -338,7 +338,7 @@ Once return is pressed:

338 |XXXXXXXXXXXXX|

339 |X X||]

340

341− if has_cursor

341+ if hasCursor

342 then putStr $ [s|

343

344 |XXXXXXXXXXXXC| |]

@@ -359,11 +359,11 @@ After return is pressed for the second time:

359 1. The cursor should be visible.

360|]

361

362−generic_output_match_confirm = do

362+genericOutputMatchConfirm = do

363 putStr $ [s|

364Did the test output match the description?

365|]

366− default_success_confirm_results

366+ defaultSuccessConfirmResults

367

368-- Explicitely definethe bytes that encode each example text.

369-- This avoids any issues with how the compiler represents string literals.

@@ -376,21 +376,21 @@ Did the test output match the description?

376--

377-- txt_0 = ↑↑↓↓←→←→BA

378

379−utf8_txt_0 :: [[Word8]]

379+utf8Txt0 :: [[Word8]]

380−utf8_txt_0 = [ [ 0xe2 , 0x86 , 0x91 ]

380+utf8Txt0 = [ [ 0xe2 , 0x86 , 0x91 ]

381− , [ 0xe2 , 0x86 , 0x91 ]

381+ , [ 0xe2 , 0x86 , 0x91 ]

382− , [ 0xe2 , 0x86 , 0x93 ]

382+ , [ 0xe2 , 0x86 , 0x93 ]

383− , [ 0xe2 , 0x86 , 0x93 ]

383+ , [ 0xe2 , 0x86 , 0x93 ]

384− , [ 0xe2 , 0x86 , 0x90 ]

384+ , [ 0xe2 , 0x86 , 0x90 ]

385− , [ 0xe2 , 0x86 , 0x92 ]

385+ , [ 0xe2 , 0x86 , 0x92 ]

386− , [ 0xe2 , 0x86 , 0x90 ]

386+ , [ 0xe2 , 0x86 , 0x90 ]

387− , [ 0xe2 , 0x86 , 0x92 ]

387+ , [ 0xe2 , 0x86 , 0x92 ]

388− , [ 0x42 ]

388+ , [ 0x42 ]

389− , [ 0x41 ]

389+ , [ 0x41 ]

390− ]

390+ ]

391−

391+

392−iso_10646_txt_0 :: String

392+iso10646Txt0 :: String

393−iso_10646_txt_0 = map toEnum

393+iso10646Txt0 = map toEnum

394 [ 8593

395 , 8593

396 , 8595

@@ -403,46 +403,46 @@ iso_10646_txt_0 = map toEnum

403 , 65

404 ]

405

406−unicode_single_width_0 = Test

406+unicodeSingleWidth0 = Test

407− { test_name = "Verify terminal can display unicode single-width characters. (Direct UTF-8)"

407+ { testName = "Verify terminal can display unicode single-width characters. (Direct UTF-8)"

408− , test_ID = "unicode_single_width_0"

408+ , testID = "unicodeSingleWidth0"

409− , test_action = do

409+ , testAction = do

410− t <- output_for_current_terminal

410+ t <- outputForCurrentTerminal

411− reserve_display t

411+ reserveDisplay t

412− hide_cursor t

412+ hideCursor t

413− withArrayLen (concat utf8_txt_0) (flip $ hPutBuf stdout)

413+ withArrayLen (concat utf8Txt0) (flip $ hPutBuf stdout)

414 hPutStr stdout "\n"

415 hPutStr stdout "0123456789\n"

416 hFlush stdout

417 getLine

418− release_display t

418+ releaseDisplay t

419− release_terminal t

419+ releaseTerminal t

420 return ()

421− , print_summary = unicode_single_width_summary

421+ , printSummary = unicodeSingleWidthSummary

422− , confirm_results = generic_output_match_confirm

422+ , confirmResults = genericOutputMatchConfirm

423 }

424

425−unicode_single_width_1 = Test

425+unicodeSingleWidth1 = Test

426− { test_name = "Verify terminal can display unicode single-width characters. (Image ops)"

426+ { testName = "Verify terminal can display unicode single-width characters. (Image ops)"

427− , test_ID = "unicode_single_width_1"

427+ , testID = "unicodeSingleWidth1"

428− , test_action = do

428+ , testAction = do

429− t <- output_for_current_terminal

429+ t <- outputForCurrentTerminal

430− reserve_display t

430+ reserveDisplay t

431− let pic = pic_for_image image

431+ let pic = picForImage image

432− image = line_0 <-> line_1

432+ image = line0 <-> line1

433− line_0 = iso_10646_string def_attr iso_10646_txt_0

433+ line0 = iso10646String defAttr iso10646Txt0

434− line_1 = string def_attr "0123456789"

434+ line1 = string defAttr "0123456789"

435− d <- display_bounds t >>= display_context t

435+ d <- displayBounds t >>= displayContext t

436− output_picture d pic

436+ outputPicture d pic

437 getLine

438− release_display t

438+ releaseDisplay t

439− release_terminal t

439+ releaseTerminal t

440 return ()

441− , print_summary = unicode_single_width_summary

441+ , printSummary = unicodeSingleWidthSummary

442− , confirm_results = generic_output_match_confirm

442+ , confirmResults = genericOutputMatchConfirm

443 }

444

445−unicode_single_width_summary = putStr [s|

445+unicodeSingleWidthSummary = putStr [s|

446Once return is pressed:

447 0. The screen will be cleared.

448 1. The cursor will be hidden.

@@ -476,55 +476,55 @@ After return is pressed for the second time:

476

477-- The second example is a unicode string containing double-width glyphs

478-- 你好吗

479−utf8_txt_1 :: [[Word8]]

479+utf8Txt1 :: [[Word8]]

480−utf8_txt_1 = [ [0xe4,0xbd,0xa0]

480+utf8Txt1 = [ [0xe4,0xbd,0xa0]

481− , [0xe5,0xa5,0xbd]

481+ , [0xe5,0xa5,0xbd]

482− , [0xe5,0x90,0x97]

482+ , [0xe5,0x90,0x97]

483− ]

483+ ]

484−

484+

485−iso_10646_txt_1 :: String

485+iso10646Txt1 :: String

486−iso_10646_txt_1 = map toEnum [20320,22909,21527]

486+iso10646Txt1 = map toEnum [20320,22909,21527]

487−

487+

488−unicode_double_width_0 = Test

488+unicodeDoubleWidth0 = Test

489− { test_name = "Verify terminal can display unicode double-width characters. (Direct UTF-8)"

489+ { testName = "Verify terminal can display unicode double-width characters. (Direct UTF-8)"

490− , test_ID = "unicode_double_width_0"

490+ , testID = "unicodeDoubleWidth0"

491− , test_action = do

491+ , testAction = do

492− t <- output_for_current_terminal

492+ t <- outputForCurrentTerminal

493− reserve_display t

493+ reserveDisplay t

494− hide_cursor t

494+ hideCursor t

495− withArrayLen (concat utf8_txt_1) (flip $ hPutBuf stdout)

495+ withArrayLen (concat utf8Txt1) (flip $ hPutBuf stdout)

496 hPutStr stdout "\n"

497 hPutStr stdout "012345\n"

498 hFlush stdout

499 getLine

500− release_display t

500+ releaseDisplay t

501− release_terminal t

501+ releaseTerminal t

502 return ()

503− , print_summary = unicode_double_width_summary

503+ , printSummary = unicodeDoubleWidthSummary

504− , confirm_results = generic_output_match_confirm

504+ , confirmResults = genericOutputMatchConfirm

505 }

506

507−unicode_double_width_1 = Test

507+unicodeDoubleWidth1 = Test

508− { test_name = "Verify terminal can display unicode double-width characters. (Image ops)"

508+ { testName = "Verify terminal can display unicode double-width characters. (Image ops)"

509− , test_ID = "unicode_double_width_1"

509+ , testID = "unicodeDoubleWidth1"

510− , test_action = do

510+ , testAction = do

511− t <- output_for_current_terminal

511+ t <- outputForCurrentTerminal

512− reserve_display t

512+ reserveDisplay t

513− let pic = pic_for_image image

513+ let pic = picForImage image

514− image = line_0 <-> line_1

514+ image = line0 <-> line1

515− line_0 = iso_10646_string def_attr iso_10646_txt_1

515+ line0 = iso10646String defAttr iso10646Txt1

516− line_1 = string def_attr "012345"

516+ line1 = string defAttr "012345"

517− d <- display_bounds t >>= display_context t

517+ d <- displayBounds t >>= displayContext t

518− output_picture d pic

518+ outputPicture d pic

519 getLine

520− release_display t

520+ releaseDisplay t

521− release_terminal t

521+ releaseTerminal t

522 return ()

523− , print_summary = unicode_double_width_summary

523+ , printSummary = unicodeDoubleWidthSummary

524− , confirm_results = generic_output_match_confirm

524+ , confirmResults = genericOutputMatchConfirm

525 }

526

527−unicode_double_width_summary = putStr [s|

527+unicodeDoubleWidthSummary = putStr [s|

528Once return is pressed:

529 0. The screen will be cleared.

530 1. The cursor will be hidden.

@@ -551,32 +551,32 @@ After return is pressed for the second time:

551 1. The cursor should be visible.

552|]

553

554−all_colors = zip [ black, red, green, yellow, blue, magenta, cyan, white ]

554+allColors = zip [ black, red, green, yellow, blue, magenta, cyan, white ]

555− [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ]

555+ [ "black", "red", "green", "yellow", "blue", "magenta", "cyan", "white" ]

556

557−all_bright_colors

557+allBrightColors

558− = zip [ bright_black, bright_red, bright_green, bright_yellow, bright_blue, bright_magenta, bright_cyan, bright_white ]

558+ = zip [ brightBlack, brightRed, brightGreen, brightYellow, brightBlue, brightMagenta, brightCyan, brightWhite ]

559 [ "bright black", "bright red", "bright green", "bright yellow", "bright blue", "bright magenta", "bright cyan", "bright white" ]

560

561−attributes_test_0 = Test

561+attributesTest0 = Test

562− { test_name = "Character attributes: foreground colors."

562+ { testName = "Character attributes: foreground colors."

563− , test_ID = "attributes_test_0"

563+ , testID = "attributesTest0"

564− , test_action = do

564+ , testAction = do

565− t <- output_for_current_terminal

565+ t <- outputForCurrentTerminal

566− reserve_display t

566+ reserveDisplay t

567− let pic = pic_for_image image

567+ let pic = picForImage image

568− image = border <|> column_0 <|> border <|> column_1 <|> border

568+ image = border <|> column0 <|> border <|> column1 <|> border

569− column_0 = vert_cat $ map line_with_color all_colors

569+ column0 = vertCat $ map lineWithColor allColors

570− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "

570+ border = vertCat $ replicate (length allColors) $ string defAttr " | "

571− column_1 = vert_cat $ map (string def_attr . snd) all_colors

571+ column1 = vertCat $ map (string defAttr . snd) allColors

572− line_with_color (c, c_name) = string (def_attr `with_fore_color` c) c_name

572+ lineWithColor (c, cName) = string (defAttr `withForeColor` c) cName

573− d <- display_bounds t >>= display_context t

573+ d <- displayBounds t >>= displayContext t

574− output_picture d pic

574+ outputPicture d pic

575 getLine

576− release_display t

576+ releaseDisplay t

577− release_terminal t

577+ releaseTerminal t

578 return ()

579− , print_summary = do

579+ , printSummary = do

580 putStr $ [s|

581Once return is pressed:

582 0. The screen will be cleared.

@@ -597,32 +597,32 @@ After return is pressed for the second time:

597 0. The screen containing the test summary should be restored.

598 1. The cursor should be visible.

599|]

600− , confirm_results = do

600+ , confirmResults = do

601 putStr $ [s|

602Did the test output match the description?

603|]

604− default_success_confirm_results

604+ defaultSuccessConfirmResults

605 }

606

607−attributes_test_1 = Test

607+attributesTest1 = Test

608− { test_name = "Character attributes: background colors."

608+ { testName = "Character attributes: background colors."

609− , test_ID = "attributes_test_1"

609+ , testID = "attributesTest1"

610− , test_action = do

610+ , testAction = do

611− t <- output_for_current_terminal

611+ t <- outputForCurrentTerminal

612− reserve_display t

612+ reserveDisplay t

613− let pic = pic_for_image image

613+ let pic = picForImage image

614− image = border <|> column_0 <|> border <|> column_1 <|> border

614+ image = border <|> column0 <|> border <|> column1 <|> border

615− column_0 = vert_cat $ map line_with_color all_colors

615+ column0 = vertCat $ map lineWithColor allColors

616− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "

616+ border = vertCat $ replicate (length allColors) $ string defAttr " | "

617− column_1 = vert_cat $ map (string def_attr . snd) all_colors

617+ column1 = vertCat $ map (string defAttr . snd) allColors

618− line_with_color (c, c_name) = string (def_attr `with_back_color` c) c_name

618+ lineWithColor (c, cName) = string (defAttr `withBackColor` c) cName

619− d <- display_bounds t >>= display_context t

619+ d <- displayBounds t >>= displayContext t

620− output_picture d pic

620+ outputPicture d pic

621 getLine

622− release_display t

622+ releaseDisplay t

623− release_terminal t

623+ releaseTerminal t

624 return ()

625− , print_summary = do

625+ , printSummary = do

626 putStr $ [s|

627Once return is pressed:

628 0. The screen will be cleared.

@@ -652,34 +652,34 @@ After return is pressed for the second time:

652 0. The screen containing the test summary should be restored.

653 1. The cursor should be visible.

654|]

655− , confirm_results = do

655+ , confirmResults = do

656 putStr $ [s|

657Did the test output match the description?

658|]

659− default_success_confirm_results

659+ defaultSuccessConfirmResults

660 }

661

662−attributes_test_2 = Test

662+attributesTest2 = Test

663− { test_name = "Character attributes: Vivid foreground colors."

663+ { testName = "Character attributes: Vivid foreground colors."

664− , test_ID = "attributes_test_2"

664+ , testID = "attributesTest2"

665− , test_action = do

665+ , testAction = do

666− t <- output_for_current_terminal

666+ t <- outputForCurrentTerminal

667− reserve_display t

667+ reserveDisplay t

668− let pic = pic_for_image image

668+ let pic = picForImage image

669− image = horiz_cat [border, column_0, border, column_1, border, column_2, border]

669+ image = horizCat [border, column0, border, column1, border, column2, border]

670− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "

670+ border = vertCat $ replicate (length allColors) $ string defAttr " | "

671− column_0 = vert_cat $ map line_with_color_0 all_colors

671+ column0 = vertCat $ map lineWithColor0 allColors

672− column_1 = vert_cat $ map line_with_color_1 all_bright_colors

672+ column1 = vertCat $ map lineWithColor1 allBrightColors

673− column_2 = vert_cat $ map (string def_attr . snd) all_colors

673+ column2 = vertCat $ map (string defAttr . snd) allColors

674− line_with_color_0 (c, c_name) = string (def_attr `with_fore_color` c) c_name

674+ lineWithColor0 (c, cName) = string (defAttr `withForeColor` c) cName

675− line_with_color_1 (c, c_name) = string (def_attr `with_fore_color` c) c_name

675+ lineWithColor1 (c, cName) = string (defAttr `withForeColor` c) cName

676− d <- display_bounds t >>= display_context t

676+ d <- displayBounds t >>= displayContext t

677− output_picture d pic

677+ outputPicture d pic

678 getLine

679− release_display t

679+ releaseDisplay t

680− release_terminal t

680+ releaseTerminal t

681 return ()

682− , print_summary = do

682+ , printSummary = do

683 putStr $ [s|

684Once return is pressed:

685 0. The screen will be cleared.

@@ -711,34 +711,34 @@ After return is pressed for the second time:

711 0. The screen containing the test summary should be restored.

712 1. The cursor should be visible.

713|]

714− , confirm_results = do

714+ , confirmResults = do

715 putStr $ [s|

716Did the test output match the description?

717|]

718− default_success_confirm_results

718+ defaultSuccessConfirmResults

719 }

720

721−attributes_test_3 = Test

721+attributesTest3 = Test

722− { test_name = "Character attributes: Vivid background colors."

722+ { testName = "Character attributes: Vivid background colors."

723− , test_ID = "attributes_test_3"

723+ , testID = "attributesTest3"

724− , test_action = do

724+ , testAction = do

725− t <- output_for_current_terminal

725+ t <- outputForCurrentTerminal

726− reserve_display t

726+ reserveDisplay t

727− let pic = pic_for_image image

727+ let pic = picForImage image

728− image = horiz_cat [border, column_0, border, column_1, border, column_2, border]

728+ image = horizCat [border, column0, border, column1, border, column2, border]

729− border = vert_cat $ replicate (length all_colors) $ string def_attr " | "

729+ border = vertCat $ replicate (length allColors) $ string defAttr " | "

730− column_0 = vert_cat $ map line_with_color_0 all_colors

730+ column0 = vertCat $ map lineWithColor0 allColors

731− column_1 = vert_cat $ map line_with_color_1 all_bright_colors

731+ column1 = vertCat $ map lineWithColor1 allBrightColors

732− column_2 = vert_cat $ map (string def_attr . snd) all_colors

732+ column2 = vertCat $ map (string defAttr . snd) allColors

733− line_with_color_0 (c, c_name) = string (def_attr `with_back_color` c) c_name

733+ lineWithColor0 (c, cName) = string (defAttr `withBackColor` c) cName

734− line_with_color_1 (c, c_name) = string (def_attr `with_back_color` c) c_name

734+ lineWithColor1 (c, cName) = string (defAttr `withBackColor` c) cName

735− d <- display_bounds t >>= display_context t

735+ d <- displayBounds t >>= displayContext t

736− output_picture d pic

736+ outputPicture d pic

737 getLine

738− release_display t

738+ releaseDisplay t

739− release_terminal t

739+ releaseTerminal t

740 return ()

741− , print_summary = do

741+ , printSummary = do

742 putStr $ [s|

743Once return is pressed:

744 0. The screen will be cleared.

@@ -778,43 +778,43 @@ After return is pressed for the second time:

778 0. The screen containing the test summary should be restored.

779 1. The cursor should be visible.

780|]

781− , confirm_results = do

781+ , confirmResults = do

782 putStr $ [s|

783Did the test output match the description?

784|]

785− default_success_confirm_results

785+ defaultSuccessConfirmResults

786 }

787

788−attr_combos =

788+attrCombos =

789 [ ( "default", id )

790− , ( "bold", flip with_style bold )

790+ , ( "bold", flip withStyle bold )

791− , ( "blink", flip with_style blink )

791+ , ( "blink", flip withStyle blink )

792− , ( "underline", flip with_style underline )

792+ , ( "underline", flip withStyle underline )

793− , ( "bold + blink", flip with_style (bold + blink) )

793+ , ( "bold + blink", flip withStyle (bold + blink) )

794− , ( "bold + underline", flip with_style (bold + underline) )

794+ , ( "bold + underline", flip withStyle (bold + underline) )

795− , ( "underline + blink", flip with_style (underline + blink) )

795+ , ( "underline + blink", flip withStyle (underline + blink) )

796− , ( "bold + blink + underline", flip with_style (bold + blink + underline) )

796+ , ( "bold + blink + underline", flip withStyle (bold + blink + underline) )

797 ]

798

799−attributes_test_4 = Test

799+attributesTest4 = Test

800− { test_name = "Character attributes: Bold; Blink; Underline."

800+ { testName = "Character attributes: Bold; Blink; Underline."

801− , test_ID = "attributes_test_4"

801+ , testID = "attributesTest4"

802− , test_action = do

802+ , testAction = do

803− t <- output_for_current_terminal

803+ t <- outputForCurrentTerminal

804− reserve_display t

804+ reserveDisplay t

805− let pic = pic_for_image image

805+ let pic = picForImage image

806− image = horiz_cat [border, column_0, border, column_1, border]

806+ image = horizCat [border, column0, border, column1, border]

807− border = vert_cat $ replicate (length attr_combos) $ string def_attr " | "

807+ border = vertCat $ replicate (length attrCombos) $ string defAttr " | "

808− column_0 = vert_cat $ map line_with_attrs attr_combos

808+ column0 = vertCat $ map lineWithAttrs attrCombos

809− column_1 = vert_cat $ map (string def_attr . fst) attr_combos

809+ column1 = vertCat $ map (string defAttr . fst) attrCombos

810− line_with_attrs (desc, attr_f) = string (attr_f def_attr) desc

810+ lineWithAttrs (desc, attrF) = string (attrF defAttr) desc

811− d <- display_bounds t >>= display_context t

811+ d <- displayBounds t >>= displayContext t

812− output_picture d pic

812+ outputPicture d pic

813 getLine

814− release_display t

814+ releaseDisplay t

815− release_terminal t

815+ releaseTerminal t

816 return ()

817− , print_summary = do

817+ , printSummary = do

818 putStr $ [s|

819Once return is pressed:

820 0. The screen will be cleared.

@@ -841,31 +841,31 @@ After return is pressed for the second time:

841 0. The screen containing the test summary should be restored.

842 1. The cursor should be visible.

843|]

844− , confirm_results = do

844+ , confirmResults = do

845 putStr $ [s|

846Did the test output match the description?

847|]

848− default_success_confirm_results

848+ defaultSuccessConfirmResults

849 }

850

851−attributes_test_5 = Test

851+attributesTest5 = Test

852− { test_name = "Character attributes: 240 color palette"

852+ { testName = "Character attributes: 240 color palette"

853− , test_ID = "attributes_test_5"

853+ , testID = "attributesTest5"

854− , test_action = do

854+ , testAction = do

855− t <- output_for_current_terminal

855+ t <- outputForCurrentTerminal

856− reserve_display t

856+ reserveDisplay t

857− let pic = pic_for_image image

857+ let pic = picForImage image

858− image = vert_cat $ map horiz_cat $ split_color_images color_images

858+ image = vertCat $ map horizCat $ splitColorImages colorImages

859− color_images = map (\i -> string (current_attr `with_back_color` Color240 i) " ") [0..239]

859+ colorImages = map (\i -> string (currentAttr `withBackColor` Color240 i) " ") [0..239]

860− split_color_images [] = []

860+ splitColorImages [] = []

861− split_color_images is = (take 20 is ++ [string def_attr " "]) : (split_color_images (drop 20 is))

861+ splitColorImages is = (take 20 is ++ [string defAttr " "]) : (splitColorImages (drop 20 is))

862− d <- display_bounds t >>= display_context t

862+ d <- displayBounds t >>= displayContext t

863− output_picture d pic

863+ outputPicture d pic

864 getLine

865− release_display t

865+ releaseDisplay t

866− release_terminal t

866+ releaseTerminal t

867 return ()

868− , print_summary = do

868+ , printSummary = do

869 putStr $ [s|

870Once return is pressed:

871 0. The screen will be cleared.

@@ -879,290 +879,290 @@ After return is pressed for the second time:

879 0. The screen containing the test summary should be restored.

880 1. The cursor should be visible.

881|]

882− , confirm_results = do

882+ , confirmResults = do

883 putStr $ [s|

884Did the test output match the description?

885|]

886− default_success_confirm_results

886+ defaultSuccessConfirmResults

887 }

888

889−inline_test_0 = Test

889+inlineTest0 = Test

890− { test_name = "Verify styled output can be performed without clearing the screen."

890+ { testName = "Verify styled output can be performed without clearing the screen."

891− , test_ID = "inline_test_0"

891+ , testID = "inlineTest0"

892− , test_action = do

892+ , testAction = do

893 putStrLn "line 1."

894− put_attr_change_ $ back_color red >> apply_style underline

894+ putAttrChange_ $ backColor red >> applyStyle underline

895 putStrLn "line 2."

896− put_attr_change_ $ default_all

896+ putAttrChange_ $ defaultAll

897 putStrLn "line 3."

898− , print_summary = putStr $ [s|

898+ , printSummary = putStr $ [s|

899lines are in order.

900The second line "line 2" should have a red background and the text underline.

901The third line "line 3" should be drawn in the same style as the first line.

902|]

903

904− , confirm_results = generic_output_match_confirm

904+ , confirmResults = genericOutputMatchConfirm

905 }

906

907−inline_test_1 = Test

907+inlineTest1 = Test

908− { test_name = "Verify styled output can be performed without clearing the screen."

908+ { testName = "Verify styled output can be performed without clearing the screen."

909− , test_ID = "inline_test_1"

909+ , testID = "inlineTest1"

910− , test_action = do

910+ , testAction = do

911 putStr "Not styled. "

912− put_attr_change_ $ back_color red >> apply_style underline

912+ putAttrChange_ $ backColor red >> applyStyle underline

913 putStr " Styled! "

914− put_attr_change_ $ default_all

914+ putAttrChange_ $ defaultAll

915 putStrLn "Not styled."

916− , print_summary = putStr $ [s|

916+ , printSummary = putStr $ [s|

917|]

918

919− , confirm_results = generic_output_match_confirm

919+ , confirmResults = genericOutputMatchConfirm

920 }

921

922−inline_test_2 = Test

922+inlineTest2 = Test

923− { test_name = "Verify styled output can be performed without clearing the screen."

923+ { testName = "Verify styled output can be performed without clearing the screen."

924− , test_ID = "inline_test_1"

924+ , testID = "inlineTest1"

925− , test_action = do

925+ , testAction = do

926 putStr "Not styled. "

927− put_attr_change_ $ back_color red >> apply_style underline

927+ putAttrChange_ $ backColor red >> applyStyle underline

928 putStr " Styled! "

929− put_attr_change_ $ default_all

929+ putAttrChange_ $ defaultAll

930 putStr "Not styled.\n"

931− , print_summary = putStr $ [s|

931+ , printSummary = putStr $ [s|

932|]

933− , confirm_results = generic_output_match_confirm

933+ , confirmResults = genericOutputMatchConfirm

934 }

935

936−cursor_hide_test_0 :: Test

936+cursorHideTest0 :: Test

937−cursor_hide_test_0 = Test

937+cursorHideTest0 = Test

938− { test_name = "Verify the cursor is hid and re-shown. issue #7"

938+ { testName = "Verify the cursor is hid and re-shown. issue #7"

939− , test_ID = "cursor_hide_test_0"

939+ , testID = "cursorHideTest0"

940− , test_action = do

940+ , testAction = do

941 vty <- mkVty def

942− show_cursor $ output_iface vty

942+ showCursor $ outputIface vty

943− set_cursor_pos (output_iface vty) 5 5

943+ setCursorPos (outputIface vty) 5 5

944− next_event vty

944+ nextEvent vty

945− hide_cursor $ output_iface vty

945+ hideCursor $ outputIface vty

946− next_event vty

946+ nextEvent vty

947 shutdown vty

948 return ()

949− , print_summary = putStr $ [s|

949+ , printSummary = putStr $ [s|

950 1. verify the cursor is displayed.

951 2. press enter

952 3. verify the cursor is hid.

953 4. press enter.

954 5. the display should return to the state before the test.

955|]

956− , confirm_results = generic_output_match_confirm

956+ , confirmResults = genericOutputMatchConfirm

957 }

958

959−output_image_and_wait :: Image -> IO ()

959+outputImageAndWait :: Image -> IO ()

960−output_image_and_wait image = do

960+outputImageAndWait image = do

961− let pic = pic_for_image image

961+ let pic = picForImage image

962− output_pic_and_wait pic

962+ outputPicAndWait pic

963−

963+

964−output_pic_and_wait :: Picture -> IO ()

964+outputPicAndWait :: Picture -> IO ()

965−output_pic_and_wait pic = do

965+outputPicAndWait pic = do

966− t <- output_for_current_terminal

966+ t <- outputForCurrentTerminal

967− reserve_display t

967+ reserveDisplay t

968− d <- display_bounds t >>= display_context t

968+ d <- displayBounds t >>= displayContext t

969− output_picture d pic

969+ outputPicture d pic

970 getLine

971− release_display t

971+ releaseDisplay t

972− release_terminal t

972+ releaseTerminal t

973 return ()

974

975−vert_crop_test_0 :: Test

975+vertCropTest0 :: Test

976−vert_crop_test_0 = Test

976+vertCropTest0 = Test

977− { test_name = "Verify bottom cropping works as expected with single column chars"

977+ { testName = "Verify bottom cropping works as expected with single column chars"

978− , test_ID = "crop_test_0"

978+ , testID = "crop_test_0"

979− , test_action = do

979+ , testAction = do

980− let block_0 = crop_bottom 2 $ vert_cat $ map (string def_attr) lorum_ipsum

980+ let block0 = cropBottom 2 $ vertCat $ map (string defAttr) lorumIpsum

981− block_1 = vert_cat $ map (string def_attr) $ take 2 lorum_ipsum

981+ block1 = vertCat $ map (string defAttr) $ take 2 lorumIpsum

982− image = block_0 <-> background_fill 10 2 <-> block_1

982+ image = block0 <-> backgroundFill 10 2 <-> block1

983− output_image_and_wait image

983+ outputImageAndWait image

984− , print_summary = putStr $ [s|

984+ , printSummary = putStr $ [s|

985 1. Verify the two text blocks are identical.

986 2. press enter.

987 3. the display should return to the state before the test.

988|]

989− , confirm_results = generic_output_match_confirm

989+ , confirmResults = genericOutputMatchConfirm

990 }

991

992−vert_crop_test_1 :: Test

992+vertCropTest1 :: Test

993−vert_crop_test_1 = Test

993+vertCropTest1 = Test

994− { test_name = "Verify bottom cropping works as expected with double column chars"

994+ { testName = "Verify bottom cropping works as expected with double column chars"

995− , test_ID = "crop_test_0"

995+ , testID = "crop_test_0"

996− , test_action = do

996+ , testAction = do

997− let block_0 = crop_bottom 2 $ vert_cat $ map (string def_attr) lorum_ipsum_chinese

997+ let block0 = cropBottom 2 $ vertCat $ map (string defAttr) lorumIpsumChinese

998− block_1 = vert_cat $ map (string def_attr) $ take 2 lorum_ipsum_chinese

998+ block1 = vertCat $ map (string defAttr) $ take 2 lorumIpsumChinese

999− image = block_0 <-> background_fill 10 2 <-> block_1

999+ image = block0 <-> backgroundFill 10 2 <-> block1

1000− output_image_and_wait image

1000+ outputImageAndWait image

1001− , print_summary = putStr $ [s|

1001+ , printSummary = putStr $ [s|

1002 1. Verify the two text blocks are identical.

1003 2. press enter.

1004 3. the display should return to the state before the test.

1005|]

1006− , confirm_results = generic_output_match_confirm

1006+ , confirmResults = genericOutputMatchConfirm

1007 }

1008

1009−vert_crop_test_2 :: Test

1009+vertCropTest2 :: Test

1010−vert_crop_test_2 = Test

1010+vertCropTest2 = Test

1011− { test_name = "Verify top cropping works as expected with single column chars"

1011+ { testName = "Verify top cropping works as expected with single column chars"

1012− , test_ID = "crop_test_0"

1012+ , testID = "crop_test_2"

1013− , test_action = do

1013+ , testAction = do

1014− let block_0 = crop_top 2 $ vert_cat $ map (string def_attr) lorum_ipsum

1014+ let block0 = cropTop 2 $ vertCat $ map (string defAttr) lorumIpsum

1015− block_1 = vert_cat $ map (string def_attr) $ drop (length lorum_ipsum - 2) lorum_ipsum

1015+ block1 = vertCat $ map (string defAttr) $ drop (length lorumIpsum - 2) lorumIpsum

1016− image = block_0 <-> background_fill 10 2 <-> block_1

1016+ image = block0 <-> backgroundFill 10 2 <-> block1

1017− output_image_and_wait image

1017+ outputImageAndWait image

1018− , print_summary = putStr $ [s|

1018+ , printSummary = putStr $ [s|

1019 1. Verify the two text blocks are identical.

1020 2. press enter.

1021 3. the display should return to the state before the test.

1022|]

1023− , confirm_results = generic_output_match_confirm

1023+ , confirmResults = genericOutputMatchConfirm

1024 }

1025

1026−vert_crop_test_3 :: Test

1026+vertCropTest3 :: Test

1027−vert_crop_test_3 = Test

1027+vertCropTest3 = Test

1028− { test_name = "Verify top cropping works as expected with double column chars"

1028+ { testName = "Verify top cropping works as expected with double column chars"

1029− , test_ID = "crop_test_0"

1029+ , testID = "crop_test_0"

1030− , test_action = do

1030+ , testAction = do

1031− let block_0 = crop_top 2 $ vert_cat $ map (string def_attr) lorum_ipsum_chinese

1031+ let block0 = cropTop 2 $ vertCat $ map (string defAttr) lorumIpsumChinese

1032− block_1 = vert_cat $ map (string def_attr) $ drop (length lorum_ipsum_chinese - 2 ) lorum_ipsum_chinese

1032+ block1 = vertCat $ map (string defAttr) $ drop (length lorumIpsumChinese - 2 ) lorumIpsumChinese

1033− image = block_0 <-> background_fill 10 2 <-> block_1

1033+ image = block0 <-> backgroundFill 10 2 <-> block1

1034− output_image_and_wait image

1034+ outputImageAndWait image

1035− , print_summary = putStr $ [s|

1035+ , printSummary = putStr $ [s|

1036 1. Verify the two text blocks are identical.

1037 2. press enter.

1038 3. the display should return to the state before the test.

1039|]

1040− , confirm_results = generic_output_match_confirm

1040+ , confirmResults = genericOutputMatchConfirm

1041 }

1042

1043−horiz_crop_test_0 :: Test

1043+horizCropTest0 :: Test

1044−horiz_crop_test_0 = Test

1044+horizCropTest0 = Test

1045− { test_name = "Verify right cropping works as expected with single column chars"

1045+ { testName = "Verify right cropping works as expected with single column chars"

1046− , test_ID = "crop_test_0"

1046+ , testID = "crop_test_0"

1047− , test_action = do

1047+ , testAction = do

1048− let base_image = vert_cat $ map (string def_attr) lorum_ipsum

1048+ let baseImage = vertCat $ map (string defAttr) lorumIpsum

1049− cropped_image = crop_right (image_width base_image `div` 2) base_image

1049+ croppedImage = cropRight (imageWidth baseImage `div` 2) baseImage

1050− image = base_image <-> background_fill 10 2 <-> cropped_image

1050+ image = baseImage <-> backgroundFill 10 2 <-> croppedImage

1051− output_image_and_wait image

1051+ outputImageAndWait image

1052− , print_summary = putStr $ [s|

1052+ , printSummary = putStr $ [s|

1053 1. Verify the bottom text block is about half the width of the top text block.

1054 2. press enter.

1055 3. the display should return to the state before the test.

1056|]

1057− , confirm_results = generic_output_match_confirm

1057+ , confirmResults = genericOutputMatchConfirm

1058 }

1059

1060−horiz_crop_test_1 :: Test

1060+horizCropTest1 :: Test

1061−horiz_crop_test_1 = Test

1061+horizCropTest1 = Test

1062− { test_name = "Verify right cropping works as expected with double column chars"

1062+ { testName = "Verify right cropping works as expected with double column chars"

1063− , test_ID = "crop_test_0"

1063+ , testID = "crop_test_0"

1064− , test_action = do

1064+ , testAction = do

1065− let base_image = vert_cat $ map (string def_attr) lorum_ipsum_chinese

1065+ let baseImage = vertCat $ map (string defAttr) lorumIpsumChinese

1066− cropped_image = crop_right (image_width base_image `div` 2) base_image

1066+ croppedImage = cropRight (imageWidth baseImage `div` 2) baseImage

1067− image = base_image <-> background_fill 10 2 <-> cropped_image

1067+ image = baseImage <-> backgroundFill 10 2 <-> croppedImage

1068− output_image_and_wait image

1068+ outputImageAndWait image

1069− , print_summary = putStr $ [s|

1069+ , printSummary = putStr $ [s|

1070 1. Verify the bottom text block is the left half of the top block. Ellipses on the right edge are OK.

1071 2. press enter.

1072 3. the display should return to the state before the test.

1073|]

1074− , confirm_results = generic_output_match_confirm

1074+ , confirmResults = genericOutputMatchConfirm

1075 }

1076

1077−horiz_crop_test_2 :: Test

1077+horizCropTest2 :: Test

1078−horiz_crop_test_2 = Test

1078+horizCropTest2 = Test

1079− { test_name = "Verify left cropping works as expected with single column chars"

1079+ { testName = "Verify left cropping works as expected with single column chars"

1080− , test_ID = "crop_test_0"

1080+ , testID = "crop_test_0"

1081− , test_action = do

1081+ , testAction = do

1082− let base_image = vert_cat $ map (string def_attr) lorum_ipsum

1082+ let baseImage = vertCat $ map (string defAttr) lorumIpsum

1083− cropped_image = crop_left (image_width base_image `div` 2) base_image

1083+ croppedImage = cropLeft (imageWidth baseImage `div` 2) baseImage

1084− image = base_image <-> background_fill 10 2 <-> cropped_image

1084+ image = baseImage <-> backgroundFill 10 2 <-> croppedImage

1085− output_image_and_wait image

1085+ outputImageAndWait image

1086− , print_summary = putStr $ [s|

1086+ , printSummary = putStr $ [s|

1087 1. Verify the bottom text block is the right half of the top text block.

1088 2. press enter.

1089 3. the display should return to the state before the test.

1090|]

1091− , confirm_results = generic_output_match_confirm

1091+ , confirmResults = genericOutputMatchConfirm

1092 }

1093

1094−horiz_crop_test_3 :: Test

1094+horizCropTest3 :: Test

1095−horiz_crop_test_3 = Test

1095+horizCropTest3 = Test

1096− { test_name = "Verify right cropping works as expected with double column chars"

1096+ { testName = "Verify right cropping works as expected with double column chars"

1097− , test_ID = "crop_test_0"

1097+ , testID = "crop_test_0"

1098− , test_action = do

1098+ , testAction = do

1099− let base_image = vert_cat $ map (string def_attr) lorum_ipsum_chinese

1099+ let baseImage = vertCat $ map (string defAttr) lorumIpsumChinese

1100− cropped_image = crop_left (image_width base_image `div` 2) base_image

1100+ croppedImage = cropLeft (imageWidth baseImage `div` 2) baseImage

1101− image = base_image <-> background_fill 10 2 <-> cropped_image

1101+ image = baseImage <-> backgroundFill 10 2 <-> croppedImage

1102− output_image_and_wait image

1102+ outputImageAndWait image

1103− , print_summary = putStr $ [s|

1103+ , printSummary = putStr $ [s|

1104 1. Verify the bottom text block is the right half of the top block. Ellipses on the left edge are OK.

1105 2. press enter.

1106 3. the display should return to the state before the test.

1107|]

1108− , confirm_results = generic_output_match_confirm

1108+ , confirmResults = genericOutputMatchConfirm

1109 }

1110

1111−layer_0 :: Test

1111+layer0 :: Test

1112−layer_0 = Test

1112+layer0 = Test

1113− { test_name = "verify layer 0"

1113+ { testName = "verify layer 0"

1114− , test_ID = "layer_0"

1114+ , testID = "layer0"

1115− , test_action = do

1115+ , testAction = do

1116− let upper_image = vert_cat $ map (string def_attr) lorum_ipsum_chinese

1116+ let upperImage = vertCat $ map (string defAttr) lorumIpsumChinese

1117− lower_image = vert_cat $ map (string def_attr) lorum_ipsum

1117+ lowerImage = vertCat $ map (string defAttr) lorumIpsum

1118− p = pic_for_layers [upper_image, lower_image]

1118+ p = picForLayers [upperImage, lowerImage]

1119− output_pic_and_wait p

1119+ outputPicAndWait p

1120− , print_summary = putStr $ [s|

1120+ , printSummary = putStr $ [s|

1121 1. Verify the text block appears to be Chinese text placed on top Latin text.

1122 2. press enter.

1123 3. the display should return to the state before the test.

1124|]

1125− , confirm_results = generic_output_match_confirm

1125+ , confirmResults = genericOutputMatchConfirm

1126 }

1127

1128−layer_1 :: Test

1128+layer1 :: Test

1129−layer_1 = Test

1129+layer1 = Test

1130− { test_name = "verify layer 1"

1130+ { testName = "verify layer 1"

1131− , test_ID = "layer_1"

1131+ , testID = "layer1"

1132− , test_action = do

1132+ , testAction = do

1133− let upper_image = vert_cat $ map (string def_attr) lorum_ipsum_chinese

1133+ let upperImage = vertCat $ map (string defAttr) lorumIpsumChinese

1134− block = resize 10 10 upper_image

1134+ block = resize 10 10 upperImage

1135− layer_0 = vert_cat $ map (string def_attr) lorum_ipsum

1135+ layer0 = vertCat $ map (string defAttr) lorumIpsum

1136− layer_1 = char_fill (def_attr `with_back_color` blue) '#' 1000 1000

1136+ layer1 = charFill (defAttr `withBackColor` blue) '#' 1000 1000

1137− cheesy_anim_0 block [layer_0, layer_1]

1137+ cheesyAnim0 block [layer0, layer1]

1138− , print_summary = putStr $ [s|

1138+ , printSummary = putStr $ [s|

1139 1. Verify the text block appears to be Chinese text moving on top a Latin text.

1140 Which is all on a background of '#' characters over blue.

1141 2. press enter.

1142 3. the display should return to the state before the test.

1143|]

1144− , confirm_results = generic_output_match_confirm

1144+ , confirmResults = genericOutputMatchConfirm

1145 }

1146

1147−cheesy_anim_0 :: Image -> [Image] -> IO ()

1147+cheesyAnim0 :: Image -> [Image] -> IO ()

1148−cheesy_anim_0 i background = do

1148+cheesyAnim0 i background = do

1149− t <- output_for_current_terminal

1149+ t <- outputForCurrentTerminal

1150− reserve_display t

1150+ reserveDisplay t

1151− bounds <- display_bounds t

1151+ bounds <- displayBounds t

1152− d <- display_context t bounds

1152+ d <- displayContext t bounds

1153 forM_ [0..100] $ \t -> do

1154 let i_offset = translate (t `mod` fst bounds)

1155 (t `div` 2 `mod` snd bounds)

1156 i

1157− let pic = pic_for_layers $ i_offset : background

1157+ let pic = picForLayers $ i_offset : background

1158− output_picture d pic

1158+ outputPicture d pic

1159 threadDelay 50000

1160− release_display t

1160+ releaseDisplay t

1161− release_terminal t

1161+ releaseTerminal t

1162 return ()

1163

1164−lorum_ipsum :: [String]

1164+lorumIpsum :: [String]

1165−lorum_ipsum = lines [s|

1165+lorumIpsum = lines [s|

1166Sed ut perspiciatis unde omnis iste natus error sit voluptatem accusantium doloremque laudantium,

1167totam rem aperiam, eaque ipsa quae ab illo inventore veritatis et quasi architecto beatae vitae

1168dicta sunt explicabo. Nemo enim ipsam voluptatem quia voluptas sit aspernatur aut odit aut fugit,

@@ -1174,8 +1174,8 @@ commodi consequatur? Quis autem vel eum iure reprehenderit qui in ea voluptate v

1174molestiae consequatur, vel illum qui dolorem eum fugiat quo voluptas nulla pariatur?

1175|]

1176

1177−lorum_ipsum_chinese :: [String]

1177+lorumIpsumChinese :: [String]

1178−lorum_ipsum_chinese = lines [s|

1178+lorumIpsumChinese = lines [s|

1179輐銛螷蟞覮裌覅詵暕鴅噮槶惝掭掝婸媥媕耏胠臿, 汫汭沎忕汌卣蚡袀僣蒮瀁瀎瀊渮湸湤緌翢,

1180腠腶舝糲蘥蠩樏殣氀蒮蹢鎒滍鸄齴櫧櫋瀩鬄鵊鵙莃荶衒, 毸溠橀簎艜薤莃荶衒翣聜蒢

1181斔櫅檷晛桼桾拻敁柧犿玒膣, 墐笓粊紒 bacon 鼀齕, 蔝蓶蓨顊顃餭姴怤骱暕蹢鎒鎛藒襓謥鄻鎟霣

test/vty-examples.cabal+6−6

@@ -27,7 +27,7 @@ executable vty-interactive-terminal-test

27 default-extensions: ScopedTypeVariables

28 ghc-options: -threaded

30− build-depends: vty,

30+ build-depends: vty == 5.*,

31 base >= 4 && < 5,

32 bytestring,

33 containers,

@@ -38,7 +38,7 @@ executable vty-interactive-terminal-test

38 parallel >= 2.2 && < 3.3,

39 parsec >= 2 && < 4,

40 string-qq,

41− terminfo >= 0.3 && < 0.4,

41+ terminfo >= 0.3 && < 0.5,

42 text >= 0.11.3,

43 unix,

44 utf8-string >= 0.3 && < 0.4,

@@ -51,7 +51,7 @@ executable vty-event-echo

51 default-extensions: ScopedTypeVariables

52 ghc-options: -threaded

54− build-depends: vty,

54+ build-depends: vty == 5.*,

55 base >= 4 && < 5,

56 array >= 0.4 && < 2.0,

57 bytestring,

@@ -71,7 +71,7 @@ executable vty-rouge

71 default-extensions: ScopedTypeVariables

72 ghc-options: -threaded

74− build-depends: vty,

74+ build-depends: vty == 5.*,

75 base >= 4 && < 5,

76 array >= 0.4 && < 2.0,

77 bytestring,

@@ -92,7 +92,7 @@ executable vty-benchmark

92 default-extensions: ScopedTypeVariables

93 ghc-options: -threaded

95− build-depends: vty,

95+ build-depends: vty == 5.*,

96 base >= 4 && < 5,

97 bytestring,

98 Cabal == 1.18.*,

@@ -106,7 +106,7 @@ executable vty-benchmark

106 QuickCheck >= 2.4,

107 random == 1.0.*,

108 string-qq,

109− terminfo >= 0.3 && < 0.4,

109+ terminfo >= 0.3 && < 0.5,

110 text >= 0.11.3,

111 unix,

112 utf8-string >= 0.3 && < 0.4,

test/vty_inline_example.hs+2−2

@@ -3,7 +3,7 @@ import Graphics.Vty.Inline

4main = do

5 putStr "Not styled. "

6− put_attr_change_ t $ back_color red >> apply_style underline

6+ putAttrChange_ t $ backColor red >> applyStyle underline

7 putStr " Styled! "

8− put_attr_change_ t $ default_all

8+ putAttrChange_ t $ defaultAll

9 putStrLn "Not styled."