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