git.iko.soy/vty
on ca2aea7 help sign in
vty/src/Data/Terminfo/Eval.hs
158 lines 5.5 kB history raw
1{-# LANGUAGE RecordWildCards #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
4{-# LANGUAGE NamedFieldPuns #-}
5{- Evaluates the paramaterized terminfo string capability with the given parameters.
6 -
7 - todo: This can be greatly simplified.
8 -}
9module Data.Terminfo.Eval ( cap_expression_required_bytes
10 , serialize_cap_expression
11 , bytes_for_range
12 )
13 where
15import Data.Marshalling
16import Data.Terminfo.Parse
18import Control.Monad.Reader
19import Control.Monad.State.Strict
21import Data.Array.Unboxed
22import Data.Bits ( (.|.) )
23import Data.List
24import Data.Word
26type Eval a = ReaderT (CapExpression,[CapParam]) (State [CapParam]) a
27type EvalIO a = ReaderT (CapExpression,[CapParam]) (StateT [CapParam] IO) a
29pop :: MonadState [CapParam] m => m CapParam
30pop = do
31 v : stack <- get
32 put stack
33 return v
35read_param :: MonadReader (CapExpression, [CapParam]) m => Word -> m CapParam
36read_param pn = do
37 (_,params) <- ask
38 return $ genericIndex params pn
40push :: MonadState [CapParam] m => CapParam -> m ()
41push v = do
42 stack <-get
43 put (v : stack)
45apply_param_ops :: CapExpression -> [CapParam] -> [CapParam]
46apply_param_ops cap params = foldl apply_param_op params (param_ops cap)
48apply_param_op :: [CapParam] -> ParamOp -> [CapParam]
49apply_param_op params IncFirstTwo = map (+ 1) params
51-- | range is 0-based offset into cap_bytes and count
52--
53-- todo: The returned list is not assured to have a length st. length == count
54bytes_for_range :: CapExpression -> (Word8, Word8) -> [Word8]
55bytes_for_range cap (offset, count)
56 = take (fromEnum count)
57 $ drop (fromEnum offset)
58 $ elems
59 $ cap_bytes cap
61cap_expression_required_bytes :: CapExpression -> [CapParam] -> Word
62cap_expression_required_bytes cap params =
63 let params' = apply_param_ops cap params
64 in fst $ runState (runReaderT (cap_ops_required_bytes $ cap_ops cap) (cap, params)) []
66cap_ops_required_bytes :: CapOps -> Eval Word
67cap_ops_required_bytes ops = do
68 counts <- mapM cap_op_required_bytes ops
69 return $ sum counts
71cap_op_required_bytes :: CapOp -> Eval Word
72cap_op_required_bytes (Bytes (_, c)) = return $ toEnum $ fromEnum c
73cap_op_required_bytes DecOut = do
74 p <- pop
75 return $ toEnum $ length $ show p
76cap_op_required_bytes (PushParam pn) = do
77 read_param pn >>= push
78 return 0
79cap_op_required_bytes (Conditional expr parts) = do
80 c_expr <- cap_ops_required_bytes expr
81 c_parts <- foldM cond_parts_required_bytes 0 parts
82 return $ c_expr + c_parts
83 where
84 cond_parts_required_bytes in_c (true_ops, false_ops) = do
85 -- (man 5 terminfo)
86 -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the
87 -- stack, testing if it is nonzero (true). If it is zero (false), control
88 -- passes to the %e (else) part.
89 v <- pop
90 c_branch <- if v /= 0
91 then cap_ops_required_bytes true_ops
92 else cap_ops_required_bytes false_ops
93 return $ in_c + c_branch
94cap_op_required_bytes BitwiseOr = do
95 v_0 <- pop
96 v_1 <- pop
97 push $ v_0 .|. v_1
98 return 0
99cap_op_required_bytes CompareEq = do
100 v_0 <- pop
101 v_1 <- pop
102 push $ if v_0 == v_1 then 1 else 0
103 return 0
104cap_op_required_bytes (LiteralInt i) = do
105 return $ toEnum $ length $ show i
107serialize_cap_expression :: CapExpression -> [CapParam] -> OutputBuffer -> IO OutputBuffer
108serialize_cap_expression cap params out_ptr = do
109 let params' = apply_param_ops cap params
110 (out_ptr', _) <- runStateT (runReaderT (serialize_cap_ops out_ptr (cap_ops cap)) (cap, params')) []
111 return out_ptr'
113serialize_cap_ops :: OutputBuffer -> CapOps -> EvalIO OutputBuffer
114serialize_cap_ops out_ptr ops = foldM serialize_cap_op out_ptr ops
116serialize_cap_op :: OutputBuffer -> CapOp -> EvalIO OutputBuffer
117serialize_cap_op out_ptr (Bytes (offset, c)) = do
118 (cap, _) <- ask
119 let out_bytes = bytes_for_range cap (offset, c)
120 serialize_bytes out_bytes out_ptr
121serialize_cap_op out_ptr DecOut = do
122 p <- pop
123 let out_str = show p
124 out_bytes = string_to_bytes out_str
125 serialize_bytes out_bytes out_ptr
126serialize_cap_op out_ptr (PushParam pn) = do
127 read_param pn >>= push
128 return out_ptr
129serialize_cap_op out_ptr (Conditional expr parts) = do
130 out_ptr' <- serialize_cap_ops out_ptr expr
131 out_ptr'' <- foldM serialize_cond_parts out_ptr' parts
132 return out_ptr''
133 where
134 serialize_cond_parts ptr (true_ops, false_ops) = do
135 -- (man 5 terminfo)
136 -- Usually the %? expr part pushes a value onto the stack, and %t pops it from the
137 -- stack, testing if it is nonzero (true). If it is zero (false), control
138 -- passes to the %e (else) part.
139 v <- pop
140 ptr' <- if v /= 0
141 then serialize_cap_ops ptr true_ops
142 else serialize_cap_ops ptr false_ops
143 return ptr'
144serialize_cap_op out_ptr BitwiseOr = do
145 v_0 <- pop
146 v_1 <- pop
147 push $ v_0 .|. v_1
148 return out_ptr
149serialize_cap_op out_ptr CompareEq = do
150 v_0 <- pop
151 v_1 <- pop
152 push $ if v_0 == v_1 then 1 else 0
153 return out_ptr
154serialize_cap_op out_ptr (LiteralInt i) = do
155 let out_str = show i
156 out_bytes = string_to_bytes out_str
157 serialize_bytes out_bytes out_ptr