git.iko.soy/vty
on master help sign in
move terminfo cap parser and output to Write
173e1f5Corey O'Connor
src/Data/Terminfo/Eval.hs+47−162
compare with master
unifiedsplit
@@ -1,43 +1,37 @@
1−{-# LANGUAGE MagicHash #-}
2{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
3−{-# LANGUAGE RecordWildCards #-}
4−{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE NoMonomorphismRestriction #-}
2{-# LANGUAGE NoMonomorphismRestriction #-}
6−{-# LANGUAGE NamedFieldPuns #-}
7{-# OPTIONS_GHC -funbox-strict-fields #-}
3{-# OPTIONS_GHC -funbox-strict-fields #-}
8{- Evaluates the paramaterized terminfo string capability with the given parameters.
4{- Evaluates the paramaterized terminfo string capability with the given parameters.
9 -
5 -
10 - todo: This can be greatly simplified.
6 - todo: This can be greatly simplified.
11 -}
7 -}
12−module Data.Terminfo.Eval ( cap_expression_required_bytes
8+module Data.Terminfo.Eval (write_cap_expr)
13− , serialize_cap_expression
14− )
15 where
9 where
16
10
17−import Data.ByteString.Internal ( memcpy )
11+import Blaze.ByteString.Builder.Word
12+import Blaze.ByteString.Builder
18import Data.Terminfo.Parse
13import Data.Terminfo.Parse
19
14
20import Control.Monad.Identity
15import Control.Monad.Identity
21import Control.Monad.State.Strict
16import Control.Monad.State.Strict
17+import Control.Monad.Writer
22
18
23−import Data.Bits ( (.|.), (.&.), xor )
19+import Data.Bits ((.|.), (.&.), xor)
24import Data.List
20import Data.List
21+import Data.Word
25
22
26−import GHC.Prim
23+import qualified Data.Vector.Unboxed as Vector
27−import GHC.Word
28
24
29-- | capability evaluator state
25-- | capability evaluator state
30data EvalState = EvalState
26data EvalState = EvalState
31− { eval_stack :: ![ CapParam ]
27+ { eval_stack :: ![CapParam]
32 , eval_expression :: !CapExpression
28 , eval_expression :: !CapExpression
33− , eval_params :: ![ CapParam ]
29+ , eval_params :: ![CapParam]
34 }
30 }
35
31
36−type EvalT m a = StateT EvalState m a
32+type Eval a = StateT EvalState (Writer Write) a
37−type Eval a = EvalT Identity a
38
33
39−{-# SPECIALIZE pop :: EvalT IO CapParam #-}
40−pop :: Monad m => EvalT m CapParam
34+pop :: Eval CapParam
41pop = do
35pop = do
42 s <- get
36 s <- get
43 let v : stack' = eval_stack s
37 let v : stack' = eval_stack s
@@ -45,14 +39,12 @@ pop = do
45 put s'
39 put s'
46 return v
40 return v
47
41
48−{-# SPECIALIZE read_param :: Word -> EvalT IO CapParam #-}
42+read_param :: Word -> Eval CapParam
49−read_param :: Monad m => Word -> EvalT m CapParam
50read_param pn = do
43read_param pn = do
51 !params <- get >>= return . eval_params
44 !params <- get >>= return . eval_params
52 return $! genericIndex params pn
45 return $! genericIndex params pn
53
46
54−{-# SPECIALIZE push :: CapParam -> EvalT IO () #-}
47+push :: CapParam -> Eval ()
55−push :: Monad m => CapParam -> EvalT m ()
56push !v = do
48push !v = do
57 s <- get
49 s <- get
58 let s' = s { eval_stack = v : eval_stack s }
50 let s' = s { eval_stack = v : eval_stack s }
@@ -64,184 +56,77 @@ apply_param_ops cap params = foldl apply_param_op params (param_ops cap)
64apply_param_op :: [CapParam] -> ParamOp -> [CapParam]
56apply_param_op :: [CapParam] -> ParamOp -> [CapParam]
65apply_param_op params IncFirstTwo = map (+ 1) params
57apply_param_op params IncFirstTwo = map (+ 1) params
66
58
67−cap_expression_required_bytes :: CapExpression -> [CapParam] -> Int
59+write_cap_expr :: CapExpression -> [CapParam] -> Write
68−cap_expression_required_bytes cap params =
60+write_cap_expr cap params =
69 let params' = apply_param_ops cap params
61 let params' = apply_param_ops cap params
70 s_0 = EvalState [] cap params'
62 s_0 = EvalState [] cap params'
71− in fromEnum $! fst $! runIdentity $! runStateT ( cap_ops_required_bytes $! cap_ops cap ) s_0
63+ in snd $ runWriter (runStateT (write_cap_ops (cap_ops cap)) s_0)
72
64
73−cap_ops_required_bytes :: CapOps -> Eval Word
65+write_cap_ops :: CapOps -> Eval ()
74−cap_ops_required_bytes ops = do
66+write_cap_ops ops = mapM_ write_cap_op ops
75− counts <- mapM cap_op_required_bytes ops
76− return $ sum counts
77
67
78−cap_op_required_bytes :: CapOp -> Eval Word
68+write_cap_op :: CapOp -> Eval ()
79−cap_op_required_bytes (Bytes _ _ c) = return $ toEnum c
69+write_cap_op (Bytes !offset !count) = do
80−cap_op_required_bytes DecOut = do
81− p <- pop
82− return $ toEnum $ length $ show p
83−cap_op_required_bytes CharOut = do
84− _ <- pop
85− return 1
86−cap_op_required_bytes (PushParam pn) = do
87− read_param pn >>= push
88− return 0
89−cap_op_required_bytes (PushValue v) = do
90− push v
91− return 0
92−cap_op_required_bytes (Conditional expr parts) = do
93− c_expr <- cap_ops_required_bytes expr
94− c_parts <- cond_parts_required_bytes parts
95− return $ c_expr + c_parts
96− where
97− cond_parts_required_bytes [] = return 0
98− cond_parts_required_bytes ( (true_ops, false_ops) : false_parts ) = do
99− -- (man 5 terminfo)
100− -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the
101− -- stack, testing if it is nonzero (true). If it is zero (false), control
102− -- passes to the %e (else) part.
103− v <- pop
104− c_total <- if v /= 0
105− then cap_ops_required_bytes true_ops
106− else do
107− c_false <- cap_ops_required_bytes false_ops
108− c_remain <- cond_parts_required_bytes false_parts
109− return $ c_false + c_remain
110− return c_total
111−cap_op_required_bytes BitwiseOr = do
112− v_1 <- pop
113− v_0 <- pop
114− push $ v_0 .|. v_1
115− return 0
116−cap_op_required_bytes BitwiseAnd = do
117− v_1 <- pop
118− v_0 <- pop
119− push $ v_0 .&. v_1
120− return 0
121−cap_op_required_bytes BitwiseXOr = do
122− v_1 <- pop
123− v_0 <- pop
124− push $ v_0 `xor` v_1
125− return 0
126−cap_op_required_bytes ArithPlus = do
127− v_1 <- pop
128− v_0 <- pop
129− push $ v_0 + v_1
130− return 0
131−cap_op_required_bytes ArithMinus = do
132− v_1 <- pop
133− v_0 <- pop
134− push $ v_0 - v_1
135− return 0
136−cap_op_required_bytes CompareEq = do
137− v_1 <- pop
138− v_0 <- pop
139− push $ if v_0 == v_1 then 1 else 0
140− return 0
141−cap_op_required_bytes CompareLt = do
142− v_1 <- pop
143− v_0 <- pop
144− push $ if v_0 < v_1 then 1 else 0
145− return 0
146−cap_op_required_bytes CompareGt = do
147− v_1 <- pop
148− v_0 <- pop
149− push $ if v_0 > v_1 then 1 else 0
150− return 0
151−
152−serialize_cap_expression :: CapExpression -> [CapParam] -> OutputBuffer -> IO OutputBuffer
153−serialize_cap_expression cap params out_ptr = do
154− let params' = apply_param_ops cap params
155− s_0 = EvalState [] cap params'
156− (!out_ptr', _) <- runStateT ( serialize_cap_ops out_ptr (cap_ops cap) ) s_0
157− return $! out_ptr'
158−
159−serialize_cap_ops :: OutputBuffer -> CapOps -> EvalT IO OutputBuffer
160−serialize_cap_ops out_ptr ops = foldM serialize_cap_op out_ptr ops
161−
162−serialize_cap_op :: OutputBuffer -> CapOp -> EvalT IO OutputBuffer
163−serialize_cap_op !out_ptr (Bytes !offset !byte_count !next_offset) = do
164 !cap <- get >>= return . eval_expression
70 !cap <- get >>= return . eval_expression
165− let ( !start_ptr, _ ) = cap_bytes cap
71+ let bytes = Vector.take count $ Vector.drop offset (cap_bytes cap)
166− !src_ptr = start_ptr `plusPtr` offset
72+ Vector.forM_ bytes $ tell.writeWord8
167− !out_ptr' = out_ptr `plusPtr` next_offset
73+write_cap_op DecOut = do
168− liftIO $! memcpy out_ptr src_ptr (fromIntegral byte_count)
169− return $! out_ptr'
170−serialize_cap_op out_ptr DecOut = do
171 p <- pop
74 p <- pop
172 let out_str = show p
75 let out_str = show p
173− out_bytes = string_to_bytes out_str
76+ forM_ out_str $ tell.writeWord8.toEnum.fromEnum
174− serialize_bytes out_bytes out_ptr
77+write_cap_op CharOut = do
175−serialize_cap_op out_ptr CharOut = do
78+ pop >>= tell.writeWord8.toEnum.fromEnum
176− W# p <- pop
177− -- XXX Truncate the character value to a single byte?
178− let !out_byte = W8# (and# p 0xFF##)
179− !out_ptr' = out_ptr `plusPtr` 1
180− liftIO $ poke out_ptr out_byte
181− return out_ptr'
182−serialize_cap_op out_ptr (PushParam pn) = do
79+write_cap_op (PushParam pn) = do
183 read_param pn >>= push
80 read_param pn >>= push
184− return out_ptr
185−serialize_cap_op out_ptr (PushValue v) = do
81+write_cap_op (PushValue v) = do
186 push v
82 push v
187− return out_ptr
188−serialize_cap_op out_ptr (Conditional expr parts) = do
83+write_cap_op (Conditional expr parts) = do
189− out_ptr' <- serialize_cap_ops out_ptr expr
84+ write_cap_ops expr
190− out_ptr'' <- serialize_cond_parts out_ptr' parts
85+ write_contitional_parts parts
191− return out_ptr''
192 where
86 where
193− serialize_cond_parts ptr [] = return ptr
87+ write_contitional_parts [] = return ()
194− serialize_cond_parts ptr ( (true_ops, false_ops) : false_parts ) = do
88+ write_contitional_parts ((true_ops, false_ops) : false_parts) = do
195 -- (man 5 terminfo)
89 -- (man 5 terminfo)
196 -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the
90 -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the
197 -- stack, testing if it is nonzero (true). If it is zero (false), control
91 -- stack, testing if it is nonzero (true). If it is zero (false), control
198 -- passes to the %e (else) part.
92 -- passes to the %e (else) part.
199 v <- pop
93 v <- pop
200− ptr'' <- if v /= 0
94+ if v /= 0
201− then serialize_cap_ops ptr true_ops
95+ then write_cap_ops true_ops
202− else do
96+ else do
203− ptr' <- serialize_cap_ops ptr false_ops
97+ write_cap_ops false_ops
204− serialize_cond_parts ptr' false_parts
98+ write_contitional_parts false_parts
205− return ptr''
99+
206−
100+write_cap_op BitwiseOr = do
207−serialize_cap_op out_ptr BitwiseOr = do
208 v_0 <- pop
101 v_0 <- pop
209 v_1 <- pop
102 v_1 <- pop
210 push $ v_0 .|. v_1
103 push $ v_0 .|. v_1
211− return out_ptr
212−serialize_cap_op out_ptr BitwiseAnd = do
104+write_cap_op BitwiseAnd = do
213 v_0 <- pop
105 v_0 <- pop
214 v_1 <- pop
106 v_1 <- pop
215 push $ v_0 .&. v_1
107 push $ v_0 .&. v_1
216− return out_ptr
217−serialize_cap_op out_ptr BitwiseXOr = do
108+write_cap_op BitwiseXOr = do
218 v_1 <- pop
109 v_1 <- pop
219 v_0 <- pop
110 v_0 <- pop
220 push $ v_0 `xor` v_1
111 push $ v_0 `xor` v_1
221− return out_ptr
112+write_cap_op ArithPlus = do
222−serialize_cap_op out_ptr ArithPlus = do
223 v_1 <- pop
113 v_1 <- pop
224 v_0 <- pop
114 v_0 <- pop
225 push $ v_0 + v_1
115 push $ v_0 + v_1
226− return out_ptr
227−serialize_cap_op out_ptr ArithMinus = do
116+write_cap_op ArithMinus = do
228 v_1 <- pop
117 v_1 <- pop
229 v_0 <- pop
118 v_0 <- pop
230 push $ v_0 - v_1
119 push $ v_0 - v_1
231− return out_ptr
120+write_cap_op CompareEq = do
232−serialize_cap_op out_ptr CompareEq = do
233 v_1 <- pop
121 v_1 <- pop
234 v_0 <- pop
122 v_0 <- pop
235 push $ if v_0 == v_1 then 1 else 0
123 push $ if v_0 == v_1 then 1 else 0
236− return out_ptr
124+write_cap_op CompareLt = do
237−serialize_cap_op out_ptr CompareLt = do
238 v_1 <- pop
125 v_1 <- pop
239 v_0 <- pop
126 v_0 <- pop
240 push $ if v_0 < v_1 then 1 else 0
127 push $ if v_0 < v_1 then 1 else 0
241− return out_ptr
128+write_cap_op CompareGt = do
242−serialize_cap_op out_ptr CompareGt = do
243 v_1 <- pop
129 v_1 <- pop
244 v_0 <- pop
130 v_0 <- pop
245 push $ if v_0 > v_1 then 1 else 0
131 push $ if v_0 > v_1 then 1 else 0
246− return out_ptr
247
132
src/Data/Terminfo/Parse.hs+16−29
@@ -1,5 +1,4 @@
1{-# LANGUAGE BangPatterns #-}
1{-# LANGUAGE BangPatterns #-}
2−{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
2{-# LANGUAGE NoMonomorphismRestriction #-}
4{-# LANGUAGE NamedFieldPuns #-}
3{-# LANGUAGE NamedFieldPuns #-}
5{-# OPTIONS_GHC -funbox-strict-fields -O #-}
4{-# OPTIONS_GHC -funbox-strict-fields -O #-}
@@ -8,29 +7,22 @@ module Data.Terminfo.Parse ( module Data.Terminfo.Parse
8 )
7 )
9 where
8 where
10
9
11−import Control.Applicative ( Applicative(..), pure, (<*>) )
12import Control.Monad ( liftM )
10import Control.Monad ( liftM )
13−import Control.Monad.Trans
14import Control.DeepSeq
11import Control.DeepSeq
15
12
16import Data.Monoid
13import Data.Monoid
17import Data.Word
14import Data.Word
18−
15+import qualified Data.Vector.Unboxed as Vector
19−import Foreign.C.Types
20−import Foreign.Marshal.Array
21−import Foreign.Ptr
22
16
23import Numeric (showHex)
17import Numeric (showHex)
24
18
25import Text.ParserCombinators.Parsec
19import Text.ParserCombinators.Parsec
26
20
27−type CapBytes = ( Ptr Word8, CSize )
28−
29data CapExpression = CapExpression
21data CapExpression = CapExpression
30 { cap_ops :: !CapOps
22 { cap_ops :: !CapOps
31− , cap_bytes :: !CapBytes
23+ , cap_bytes :: !(Vector.Vector Word8)
32 , source_string :: !String
24 , source_string :: !String
33− , param_count :: !Word
25+ , param_count :: !Int
34 , param_ops :: !ParamOps
26 , param_ops :: !ParamOps
35 } deriving (Eq)
27 } deriving (Eq)
36
28
@@ -51,7 +43,7 @@ type CapParam = Word
51
43
52type CapOps = [CapOp]
44type CapOps = [CapOp]
53data CapOp =
45data CapOp =
54− Bytes !Int !CSize !Int
46+ Bytes !Int !Int -- offset count
55 | DecOut | CharOut
47 | DecOut | CharOut
56 -- This stores a 0-based index to the parameter. However the operation that implies this op is
48 -- This stores a 0-based index to the parameter. However the operation that implies this op is
57 -- 1-based
49 -- 1-based
@@ -68,7 +60,7 @@ data CapOp =
68 deriving (Show, Eq)
60 deriving (Show, Eq)
69
61
70instance NFData CapOp where
62instance NFData CapOp where
71− rnf (Bytes offset _count next_offset) = rnf offset `seq` rnf next_offset
63+ rnf (Bytes offset byte_count ) = rnf offset `seq` rnf byte_count
72 rnf (PushParam pn) = rnf pn
64 rnf (PushParam pn) = rnf pn
73 rnf (PushValue v) = rnf v
65 rnf (PushValue v) = rnf v
74 rnf (Conditional c_expr c_parts) = rnf c_expr `seq` rnf c_parts
66 rnf (Conditional c_expr c_parts) = rnf c_expr `seq` rnf c_parts
@@ -91,33 +83,28 @@ data ParamOp =
91instance NFData ParamOp where
83instance NFData ParamOp where
92 rnf IncFirstTwo = ()
84 rnf IncFirstTwo = ()
93
85
94−parse_cap_expression :: ( Applicative m
95− , MonadIO m
96− )
97− => String
98− -> m ( Either ParseError CapExpression )
86+parse_cap_expression :: String -> Either ParseError CapExpression
99parse_cap_expression cap_string =
87parse_cap_expression cap_string =
100 let v = runParser cap_expression_parser
88 let v = runParser cap_expression_parser
101 initial_build_state
89 initial_build_state
102 "terminfo cap"
90 "terminfo cap"
103 cap_string
91 cap_string
104 in case v of
92 in case v of
105− Left e -> return $ Left e
93+ Left e -> Left e
106− Right build_results -> pure Right <*> construct_cap_expression cap_string build_results
94+ Right build_results -> Right $ construct_cap_expression cap_string build_results
107
95
108−construct_cap_expression :: MonadIO m => [Char] -> BuildResults -> m CapExpression
96+construct_cap_expression :: [Char] -> BuildResults -> CapExpression
109−construct_cap_expression cap_string build_results = do
97+construct_cap_expression cap_string build_results =
110− byte_array <- liftIO $ newArray (map ( toEnum . fromEnum ) cap_string )
111 let expr = CapExpression
98 let expr = CapExpression
112 { cap_ops = out_cap_ops build_results
99 { cap_ops = out_cap_ops build_results
113 -- The cap bytes are the lower 8 bits of the input string's characters.
100 -- The cap bytes are the lower 8 bits of the input string's characters.
114 -- \todo Verify the input string actually contains an 8bit byte per character.
101 -- \todo Verify the input string actually contains an 8bit byte per character.
115− , cap_bytes = ( byte_array, toEnum $! length cap_string )
102+ , cap_bytes = Vector.fromList $ map (toEnum.fromEnum) cap_string
116 , source_string = cap_string
103 , source_string = cap_string
117 , param_count = out_param_count build_results
104 , param_count = out_param_count build_results
118 , param_ops = out_param_ops build_results
105 , param_ops = out_param_ops build_results
119 }
106 }
120− return $! rnf expr `seq` expr
107+ in rnf expr `seq` expr
121
108
122type CapParser a = GenParser Char BuildState a
109type CapParser a = GenParser Char BuildState a
123
110
@@ -137,7 +124,7 @@ literal_percent_parser = do
137 _ <- char '%'
124 _ <- char '%'
138 start_offset <- getState >>= return . next_offset
125 start_offset <- getState >>= return . next_offset
139 inc_offset 1
126 inc_offset 1
140− return $ BuildResults 0 [Bytes start_offset 1 1] []
127+ return $ BuildResults 0 [Bytes start_offset 1] []
141
128
142param_op_parser :: CapParser BuildResults
129param_op_parser :: CapParser BuildResults
143param_op_parser
130param_op_parser
@@ -163,7 +150,7 @@ push_op_parser = do
163 _ <- char 'p'
150 _ <- char 'p'
164 param_n <- digit >>= return . (\d -> read [d])
151 param_n <- digit >>= return . (\d -> read [d])
165 inc_offset 2
152 inc_offset 2
166− return $ BuildResults param_n [ PushParam $ param_n - 1 ] []
153+ return $ BuildResults (fromEnum param_n) [PushParam $ param_n - 1] []
167
154
168dec_out_parser :: CapParser BuildResults
155dec_out_parser :: CapParser BuildResults
169dec_out_parser = do
156dec_out_parser = do
@@ -311,7 +298,7 @@ bytes_op_parser = do
311 !s <- getState
298 !s <- getState
312 let s' = s { next_offset = start_offset + c }
299 let s' = s { next_offset = start_offset + c }
313 setState s'
300 setState s'
314− return $ BuildResults 0 [Bytes start_offset ( toEnum c ) c ] []
301+ return $ BuildResults 0 [Bytes start_offset c] []
315
302
316char_const_parser :: CapParser BuildResults
303char_const_parser :: CapParser BuildResults
317char_const_parser = do
304char_const_parser = do
@@ -335,7 +322,7 @@ initial_build_state :: BuildState
335initial_build_state = BuildState 0
322initial_build_state = BuildState 0
336
323
337data BuildResults = BuildResults
324data BuildResults = BuildResults
338− { out_param_count :: !Word
325+ { out_param_count :: !Int
339 , out_cap_ops :: !CapOps
326 , out_cap_ops :: !CapOps
340 , out_param_ops :: !ParamOps
327 , out_param_ops :: !ParamOps
341 }
328 }
src/Graphics/Vty/Input/Internal.hs+3−3
@@ -206,12 +206,12 @@ run_input_processor_loop classify_table input stop_flag = do
206-- This is an example of an algorithm where code coverage could be high, even 100%, but the
206-- This is an example of an algorithm where code coverage could be high, even 100%, but the
207-- algorithm still under tested. I should collect more of these examples...
207-- algorithm still under tested. I should collect more of these examples...
208initInputForFd :: IORef Config -> ClassifyTable -> Fd -> IO Input
208initInputForFd :: IORef Config -> ClassifyTable -> Fd -> IO Input
209−initInputForFd config_ref classify_table input_fd = do
209+initInputForFd in_config_ref classify_table in_input_fd = do
210 stop_flag <- newIORef False
210 stop_flag <- newIORef False
211 input <- Input <$> newChan
211 input <- Input <$> newChan
212 <*> pure (writeIORef stop_flag True)
212 <*> pure (writeIORef stop_flag True)
213− <*> pure config_ref
213+ <*> pure in_config_ref
214− <*> pure input_fd
214+ <*> pure in_input_fd
215 _ <- forkOS $ run_input_processor_loop classify_table input stop_flag
215 _ <- forkOS $ run_input_processor_loop classify_table input stop_flag
216 return input
216 return input
217
217
vty.cabal−1
@@ -44,7 +44,6 @@ library
44 containers,
44 containers,
45 data-default >= 0.5.3,
45 data-default >= 0.5.3,
46 deepseq >= 1.1 && < 1.4,
46 deepseq >= 1.1 && < 1.4,
47− ghc-prim,
48 lens >= 3.9.0.2,
47 lens >= 3.9.0.2,
49 -- required for nice installation with yi
48 -- required for nice installation with yi
50 hashable >= 1.2,
49 hashable >= 1.2,