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