git.iko.soy/vty
on 033acfa help sign in
vty/src/Data/Terminfo/Eval.hs
248 lines 7.8 kB history raw
1{-# LANGUAGE MagicHash #-}
2{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE ScopedTypeVariables #-}
4{-# LANGUAGE RecordWildCards #-}
5{-# LANGUAGE FlexibleContexts #-}
6{-# LANGUAGE NoMonomorphismRestriction #-}
7{-# LANGUAGE NamedFieldPuns #-}
8{-# OPTIONS_GHC -funbox-strict-fields #-}
9{- Evaluates the paramaterized terminfo string capability with the given parameters.
10 -
11 - todo: This can be greatly simplified.
12 -}
13module Data.Terminfo.Eval ( cap_expression_required_bytes
14 , serialize_cap_expression
15 )
16 where
18import Data.ByteString.Internal ( memcpy )
19import Data.Marshalling
20import Data.Terminfo.Parse
22import Control.Monad.Identity
23import Control.Monad.State.Strict
25import Data.Bits ( (.|.), (.&.), xor )
26import Data.List
28import GHC.Prim
29import GHC.Word
31data EvalState = EvalState
32 { eval_stack :: ![ CapParam ]
33 , eval_expression :: !CapExpression
34 , eval_params :: ![ CapParam ]
35 }
37type EvalT m a = StateT EvalState m a
38type Eval a = EvalT Identity a
40{-# SPECIALIZE pop :: EvalT IO CapParam #-}
41pop :: Monad m => EvalT m CapParam
42pop = do
43 s <- get
44 let v : stack' = eval_stack s
45 s' = s { eval_stack = stack' }
46 put s'
47 return v
49{-# SPECIALIZE read_param :: Word -> EvalT IO CapParam #-}
50read_param :: Monad m => Word -> EvalT m CapParam
51read_param pn = do
52 !params <- get >>= return . eval_params
53 return $! genericIndex params pn
55{-# SPECIALIZE push :: CapParam -> EvalT IO () #-}
56push :: Monad m => CapParam -> EvalT m ()
57push !v = do
58 s <- get
59 let s' = s { eval_stack = v : eval_stack s }
60 put s'
62apply_param_ops :: CapExpression -> [CapParam] -> [CapParam]
63apply_param_ops cap params = foldl apply_param_op params (param_ops cap)
65apply_param_op :: [CapParam] -> ParamOp -> [CapParam]
66apply_param_op params IncFirstTwo = map (+ 1) params
68cap_expression_required_bytes :: CapExpression -> [CapParam] -> Word
69cap_expression_required_bytes cap params =
70 let params' = apply_param_ops cap params
71 s_0 = EvalState [] cap params'
72 in fst $! runIdentity $! runStateT ( cap_ops_required_bytes $! cap_ops cap ) s_0
74cap_ops_required_bytes :: CapOps -> Eval Word
75cap_ops_required_bytes ops = do
76 counts <- mapM cap_op_required_bytes ops
77 return $ sum counts
79cap_op_required_bytes :: CapOp -> Eval Word
80cap_op_required_bytes (Bytes _ _ c) = return $ toEnum c
81cap_op_required_bytes DecOut = do
82 p <- pop
83 return $ toEnum $ length $ show p
84cap_op_required_bytes CharOut = do
85 _ <- pop
86 return 1
87cap_op_required_bytes (PushParam pn) = do
88 read_param pn >>= push
89 return 0
90cap_op_required_bytes (PushValue v) = do
91 push v
92 return 0
93cap_op_required_bytes (Conditional expr parts) = do
94 c_expr <- cap_ops_required_bytes expr
95 c_parts <- cond_parts_required_bytes parts
96 return $ c_expr + c_parts
97 where
98 cond_parts_required_bytes [] = return 0
99 cond_parts_required_bytes ( (true_ops, false_ops) : false_parts ) = do
100 -- (man 5 terminfo)
101 -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the
102 -- stack, testing if it is nonzero (true). If it is zero (false), control
103 -- passes to the %e (else) part.
104 v <- pop
105 c_total <- if v /= 0
106 then cap_ops_required_bytes true_ops
107 else do
108 c_false <- cap_ops_required_bytes false_ops
109 c_remain <- cond_parts_required_bytes false_parts
110 return $ c_false + c_remain
111 return c_total
112cap_op_required_bytes BitwiseOr = do
113 v_1 <- pop
114 v_0 <- pop
115 push $ v_0 .|. v_1
116 return 0
117cap_op_required_bytes BitwiseAnd = do
118 v_1 <- pop
119 v_0 <- pop
120 push $ v_0 .&. v_1
121 return 0
122cap_op_required_bytes BitwiseXOr = do
123 v_1 <- pop
124 v_0 <- pop
125 push $ v_0 `xor` v_1
126 return 0
127cap_op_required_bytes ArithPlus = do
128 v_1 <- pop
129 v_0 <- pop
130 push $ v_0 + v_1
131 return 0
132cap_op_required_bytes ArithMinus = do
133 v_1 <- pop
134 v_0 <- pop
135 push $ v_0 - v_1
136 return 0
137cap_op_required_bytes CompareEq = do
138 v_1 <- pop
139 v_0 <- pop
140 push $ if v_0 == v_1 then 1 else 0
141 return 0
142cap_op_required_bytes CompareLt = do
143 v_1 <- pop
144 v_0 <- pop
145 push $ if v_0 < v_1 then 1 else 0
146 return 0
147cap_op_required_bytes CompareGt = do
148 v_1 <- pop
149 v_0 <- pop
150 push $ if v_0 > v_1 then 1 else 0
151 return 0
153serialize_cap_expression :: CapExpression -> [CapParam] -> OutputBuffer -> IO OutputBuffer
154serialize_cap_expression cap params out_ptr = do
155 let params' = apply_param_ops cap params
156 s_0 = EvalState [] cap params'
157 (!out_ptr', _) <- runStateT ( serialize_cap_ops out_ptr (cap_ops cap) ) s_0
158 return $! out_ptr'
160serialize_cap_ops :: OutputBuffer -> CapOps -> EvalT IO OutputBuffer
161serialize_cap_ops out_ptr ops = foldM serialize_cap_op out_ptr ops
163serialize_cap_op :: OutputBuffer -> CapOp -> EvalT IO OutputBuffer
164serialize_cap_op !out_ptr ( Bytes !offset !byte_count !next_offset ) = do
165 !cap <- get >>= return . eval_expression
166 let ( !start_ptr, _ ) = cap_bytes cap
167 !src_ptr = start_ptr `plusPtr` offset
168 !out_ptr' = out_ptr `plusPtr` next_offset
169 liftIO $! memcpy out_ptr src_ptr byte_count
170 return $! out_ptr'
171serialize_cap_op out_ptr DecOut = do
172 p <- pop
173 let out_str = show p
174 out_bytes = string_to_bytes out_str
175 serialize_bytes out_bytes out_ptr
176serialize_cap_op out_ptr CharOut = do
177 W# p <- pop
178 -- XXX Truncate the character value to a single byte?
179 let !out_byte = W8# (and# p 0xFF##)
180 !out_ptr' = out_ptr `plusPtr` 1
181 liftIO $ poke out_ptr out_byte
182 return out_ptr'
183serialize_cap_op out_ptr (PushParam pn) = do
184 read_param pn >>= push
185 return out_ptr
186serialize_cap_op out_ptr (PushValue v) = do
187 push v
188 return out_ptr
189serialize_cap_op out_ptr (Conditional expr parts) = do
190 out_ptr' <- serialize_cap_ops out_ptr expr
191 out_ptr'' <- serialize_cond_parts out_ptr' parts
192 return out_ptr''
193 where
194 serialize_cond_parts ptr [] = return ptr
195 serialize_cond_parts ptr ( (true_ops, false_ops) : false_parts ) = do
196 -- (man 5 terminfo)
197 -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the
198 -- stack, testing if it is nonzero (true). If it is zero (false), control
199 -- passes to the %e (else) part.
200 v <- pop
201 ptr'' <- if v /= 0
202 then serialize_cap_ops ptr true_ops
203 else do
204 ptr' <- serialize_cap_ops ptr false_ops
205 serialize_cond_parts ptr' false_parts
206 return ptr''
208serialize_cap_op out_ptr BitwiseOr = do
209 v_0 <- pop
210 v_1 <- pop
211 push $ v_0 .|. v_1
212 return out_ptr
213serialize_cap_op out_ptr BitwiseAnd = do
214 v_0 <- pop
215 v_1 <- pop
216 push $ v_0 .&. v_1
217 return out_ptr
218serialize_cap_op out_ptr BitwiseXOr = do
219 v_1 <- pop
220 v_0 <- pop
221 push $ v_0 `xor` v_1
222 return out_ptr
223serialize_cap_op out_ptr ArithPlus = do
224 v_1 <- pop
225 v_0 <- pop
226 push $ v_0 + v_1
227 return out_ptr
228serialize_cap_op out_ptr ArithMinus = do
229 v_1 <- pop
230 v_0 <- pop
231 push $ v_0 - v_1
232 return out_ptr
233serialize_cap_op out_ptr CompareEq = do
234 v_1 <- pop
235 v_0 <- pop
236 push $ if v_0 == v_1 then 1 else 0
237 return out_ptr
238serialize_cap_op out_ptr CompareLt = do
239 v_1 <- pop
240 v_0 <- pop
241 push $ if v_0 < v_1 then 1 else 0
242 return out_ptr
243serialize_cap_op out_ptr CompareGt = do
244 v_1 <- pop
245 v_0 <- pop
246 push $ if v_0 > v_1 then 1 else 0
247 return out_ptr