@@ -1,43 +1,37 @@
1−{-# LANGUAGE MagicHash #-}
21{-# LANGUAGE BangPatterns #-}
3−{-# LANGUAGE RecordWildCards #-}
4−{-# LANGUAGE FlexibleContexts #-}
52{-# LANGUAGE NoMonomorphismRestriction #-}
6−{-# LANGUAGE NamedFieldPuns #-}
73{-# OPTIONS_GHC -funbox-strict-fields #-}
84{- Evaluates the paramaterized terminfo string capability with the given parameters.
95 -
106 - todo: This can be greatly simplified.
117 -}
12−module Data.Terminfo.Eval ( cap_expression_required_bytes
13− , serialize_cap_expression
14− )
8+module Data.Terminfo.Eval (write_cap_expr)
159 where
1610
17−import Data.ByteString.Internal ( memcpy )
11+import Blaze.ByteString.Builder.Word
12+import Blaze.ByteString.Builder
1813import Data.Terminfo.Parse
1914
2015import Control.Monad.Identity
2116import Control.Monad.State.Strict
17+import Control.Monad.Writer
2218
23−import Data.Bits ( (.|.), (.&.), xor )
19+import Data.Bits ((.|.), (.&.), xor)
2420import Data.List
21+import Data.Word
2522
26−import GHC.Prim
27−import GHC.Word
23+import qualified Data.Vector.Unboxed as Vector
2824
2925-- | capability evaluator state
3026data EvalState = EvalState
31− { eval_stack :: ![ CapParam ]
27+ { eval_stack :: ![CapParam]
3228 , eval_expression :: !CapExpression
33− , eval_params :: ![ CapParam ]
29+ , eval_params :: ![CapParam]
3430 }
3531
36−type EvalT m a = StateT EvalState m a
37−type Eval a = EvalT Identity a
32+type Eval a = StateT EvalState (Writer Write) a
3833
39−{-# SPECIALIZE pop :: EvalT IO CapParam #-}
40−pop :: Monad m => EvalT m CapParam
34+pop :: Eval CapParam
4135pop = do
4236 s <- get
4337 let v : stack' = eval_stack s
@@ -45,14 +39,12 @@ pop = do
4539 put s'
4640 return v
4741
48−{-# SPECIALIZE read_param :: Word -> EvalT IO CapParam #-}
49−read_param :: Monad m => Word -> EvalT m CapParam
42+read_param :: Word -> Eval CapParam
5043read_param pn = do
5144 !params <- get >>= return . eval_params
5245 return $! genericIndex params pn
5346
54−{-# SPECIALIZE push :: CapParam -> EvalT IO () #-}
55−push :: Monad m => CapParam -> EvalT m ()
47+push :: CapParam -> Eval ()
5648push !v = do
5749 s <- get
5850 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)
6456apply_param_op :: [CapParam] -> ParamOp -> [CapParam]
6557apply_param_op params IncFirstTwo = map (+ 1) params
6658
67−cap_expression_required_bytes :: CapExpression -> [CapParam] -> Int
68−cap_expression_required_bytes cap params =
59+write_cap_expr :: CapExpression -> [CapParam] -> Write
60+write_cap_expr cap params =
6961 let params' = apply_param_ops cap params
7062 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)
7264
73−cap_ops_required_bytes :: CapOps -> Eval Word
74−cap_ops_required_bytes ops = do
75− counts <- mapM cap_op_required_bytes ops
76− return $ sum counts
65+write_cap_ops :: CapOps -> Eval ()
66+write_cap_ops ops = mapM_ write_cap_op ops
7767
78−cap_op_required_bytes :: CapOp -> Eval Word
79−cap_op_required_bytes (Bytes _ _ c) = return $ toEnum c
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
68+write_cap_op :: CapOp -> Eval ()
69+write_cap_op (Bytes !offset !count) = do
16470 !cap <- get >>= return . eval_expression
165− let ( !start_ptr, _ ) = cap_bytes cap
166− !src_ptr = start_ptr `plusPtr` offset
167− !out_ptr' = out_ptr `plusPtr` next_offset
168− liftIO $! memcpy out_ptr src_ptr (fromIntegral byte_count)
169− return $! out_ptr'
170−serialize_cap_op out_ptr DecOut = do
71+ let bytes = Vector.take count $ Vector.drop offset (cap_bytes cap)
72+ Vector.forM_ bytes $ tell.writeWord8
73+write_cap_op DecOut = do
17174 p <- pop
17275 let out_str = show p
173− out_bytes = string_to_bytes out_str
174− serialize_bytes out_bytes out_ptr
175−serialize_cap_op out_ptr CharOut = do
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
76+ forM_ out_str $ tell.writeWord8.toEnum.fromEnum
77+write_cap_op CharOut = do
78+ pop >>= tell.writeWord8.toEnum.fromEnum
79+write_cap_op (PushParam pn) = do
18380 read_param pn >>= push
184− return out_ptr
185−serialize_cap_op out_ptr (PushValue v) = do
81+write_cap_op (PushValue v) = do
18682 push v
187− return out_ptr
188−serialize_cap_op out_ptr (Conditional expr parts) = do
189− out_ptr' <- serialize_cap_ops out_ptr expr
190− out_ptr'' <- serialize_cond_parts out_ptr' parts
191− return out_ptr''
83+write_cap_op (Conditional expr parts) = do
84+ write_cap_ops expr
85+ write_contitional_parts parts
19286 where
193− serialize_cond_parts ptr [] = return ptr
194− serialize_cond_parts ptr ( (true_ops, false_ops) : false_parts ) = do
87+ write_contitional_parts [] = return ()
88+ write_contitional_parts ((true_ops, false_ops) : false_parts) = do
19589 -- (man 5 terminfo)
19690 -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the
19791 -- stack, testing if it is nonzero (true). If it is zero (false), control
19892 -- passes to the %e (else) part.
19993 v <- pop
200− ptr'' <- if v /= 0
201− then serialize_cap_ops ptr true_ops
202− else do
203− ptr' <- serialize_cap_ops ptr false_ops
204− serialize_cond_parts ptr' false_parts
205− return ptr''
206−
207−serialize_cap_op out_ptr BitwiseOr = do
94+ if v /= 0
95+ then write_cap_ops true_ops
96+ else do
97+ write_cap_ops false_ops
98+ write_contitional_parts false_parts
99+
100+write_cap_op BitwiseOr = do
208101 v_0 <- pop
209102 v_1 <- pop
210103 push $ v_0 .|. v_1
211− return out_ptr
212−serialize_cap_op out_ptr BitwiseAnd = do
104+write_cap_op BitwiseAnd = do
213105 v_0 <- pop
214106 v_1 <- pop
215107 push $ v_0 .&. v_1
216− return out_ptr
217−serialize_cap_op out_ptr BitwiseXOr = do
108+write_cap_op BitwiseXOr = do
218109 v_1 <- pop
219110 v_0 <- pop
220111 push $ v_0 `xor` v_1
221− return out_ptr
222−serialize_cap_op out_ptr ArithPlus = do
112+write_cap_op ArithPlus = do
223113 v_1 <- pop
224114 v_0 <- pop
225115 push $ v_0 + v_1
226− return out_ptr
227−serialize_cap_op out_ptr ArithMinus = do
116+write_cap_op ArithMinus = do
228117 v_1 <- pop
229118 v_0 <- pop
230119 push $ v_0 - v_1
231− return out_ptr
232−serialize_cap_op out_ptr CompareEq = do
120+write_cap_op CompareEq = do
233121 v_1 <- pop
234122 v_0 <- pop
235123 push $ if v_0 == v_1 then 1 else 0
236− return out_ptr
237−serialize_cap_op out_ptr CompareLt = do
124+write_cap_op CompareLt = do
238125 v_1 <- pop
239126 v_0 <- pop
240127 push $ if v_0 < v_1 then 1 else 0
241− return out_ptr
242−serialize_cap_op out_ptr CompareGt = do
128+write_cap_op CompareGt = do
243129 v_1 <- pop
244130 v_0 <- pop
245131 push $ if v_0 > v_1 then 1 else 0
246− return out_ptr
247132