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