git.iko.soy/vty
on bcda3db help sign in
vty/src/Data/Terminfo/Parse.hs
329 lines 9.9 kB history raw
1{-# LANGUAGE ScopedTypeVariables #-}
2{-# LANGUAGE BangPatterns #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE NoMonomorphismRestriction #-}
5{-# LANGUAGE NamedFieldPuns #-}
6{-# OPTIONS_GHC -funbox-strict-fields -O #-}
7module Data.Terminfo.Parse ( module Data.Terminfo.Parse
8 , Text.ParserCombinators.Parsec.ParseError
9 )
10 where
12import Control.Applicative ( Applicative(..), pure, (<*>) )
13import Control.Monad ( liftM )
14import Control.Monad.Trans
15import Control.Parallel.Strategies
17import Data.Array.Unboxed
18import Data.Monoid
19import Data.Word
21import Foreign.C.Types
22import Foreign.Marshal.Array
23import Foreign.Ptr
25import Text.ParserCombinators.Parsec
27type CapBytes = ( Ptr Word8, CSize )
29data CapExpression = CapExpression
30 { cap_ops :: !CapOps
31 , cap_bytes :: !CapBytes
32 , source_string :: !String
33 , param_count :: !Word
34 , param_ops :: !ParamOps
35 }
37instance NFData CapExpression where
38 rnf (CapExpression ops !_bytes !_str !_c !_p_ops)
39 = rnf ops
41type CapParam = Word
43type CapOps = [CapOp]
44data CapOp =
45 Bytes !Int !CSize !Int
46 | DecOut | CharOut
47 -- This stores a 0-based index to the parameter. However the operation that implies this op is
48 -- 1-based
49 | PushParam !Word | PushValue !Word
50 -- The conditional parts are the sequence of (%t expression, %e expression) pairs.
51 -- The %e expression may be NOP
52 | Conditional
53 { conditional_expr :: !CapOps
54 , conditional_parts :: ![(CapOps, CapOps)]
55 }
56 | BitwiseOr | BitwiseXOr | BitwiseAnd
57 | ArithPlus | ArithMinus
58 | CompareEq | CompareLt | CompareGt
59 deriving ( Show )
61instance NFData CapOp where
62 rnf ( Bytes offset count next_offset ) = rnf offset
63 rnf (PushParam !_pn) = ()
64 rnf (PushValue !_v) = ()
65 rnf (Conditional c_expr c_parts) = rnf c_expr >| rnf c_parts
66 rnf _ = ()
68type ParamOps = [ParamOp]
69data ParamOp =
70 IncFirstTwo
71 deriving ( Show )
73parse_cap_expression :: ( Applicative m
74 , MonadIO m
75 )
76 => String
77 -> m ( Either ParseError CapExpression )
78parse_cap_expression cap_string =
79 let v = runParser cap_expression_parser
80 initial_build_state
81 "terminfo cap"
82 cap_string
83 in case v of
84 Left e -> return $ Left e
85 Right build_results -> pure Right <*> construct_cap_expression cap_string build_results
87construct_cap_expression cap_string build_results = do
88 byte_array <- liftIO $ newArray (map ( toEnum . fromEnum ) cap_string )
89 let expr = CapExpression
90 { cap_ops = out_cap_ops build_results
91 -- The cap bytes are the lower 8 bits of the input string's characters.
92 -- \todo Verify the input string actually contains an 8bit byte per character.
93 , cap_bytes = ( byte_array, toEnum $! length cap_string )
94 , source_string = cap_string
95 , param_count = out_param_count build_results
96 , param_ops = out_param_ops build_results
97 }
98 return (demanding expr (rnf expr))
100type CapParser a = GenParser Char BuildState a
102cap_expression_parser :: CapParser BuildResults
103cap_expression_parser = do
104 rs <- many $ param_escape_parser <|> bytes_op_parser
105 return $ mconcat rs
107param_escape_parser :: CapParser BuildResults
108param_escape_parser = do
109 _ <- char '%'
110 inc_offset 1
111 literal_percent_parser <|> param_op_parser
113literal_percent_parser :: CapParser BuildResults
114literal_percent_parser = do
115 _ <- char '%'
116 start_offset <- getState >>= return . next_offset
117 inc_offset 1
118 return $ BuildResults 0 [Bytes start_offset 1 1] []
120param_op_parser :: CapParser BuildResults
121param_op_parser
122 = increment_op_parser
123 <|> push_op_parser
124 <|> dec_out_parser
125 <|> char_out_parser
126 <|> conditional_op_parser
127 <|> bitwise_op_parser
128 <|> arith_op_parser
129 <|> literal_int_op_parser
130 <|> compare_op_parser
131 <|> char_const_parser
133increment_op_parser :: CapParser BuildResults
134increment_op_parser = do
135 _ <- char 'i'
136 inc_offset 1
137 return $ BuildResults 0 [] [ IncFirstTwo ]
139push_op_parser :: CapParser BuildResults
140push_op_parser = do
141 _ <- char 'p'
142 param_n <- digit >>= return . (\d -> read [d])
143 inc_offset 2
144 return $ BuildResults param_n [ PushParam $ param_n - 1 ] []
146dec_out_parser :: CapParser BuildResults
147dec_out_parser = do
148 _ <- char 'd'
149 inc_offset 1
150 return $ BuildResults 0 [ DecOut ] []
152char_out_parser :: CapParser BuildResults
153char_out_parser = do
154 _ <- char 'c'
155 inc_offset 1
156 return $ BuildResults 0 [ CharOut ] []
158conditional_op_parser :: CapParser BuildResults
159conditional_op_parser = do
160 _ <- char '?'
161 inc_offset 1
162 cond_part <- many_expr conditional_true_parser
163 parts <- many_p
164 ( do
165 true_part <- many_expr $ choice [ try $ lookAhead conditional_end_parser
166 , conditional_false_parser
167 ]
168 false_part <- many_expr $ choice [ try $ lookAhead conditional_end_parser
169 , conditional_true_parser
170 ]
171 return ( true_part, false_part )
172 )
173 conditional_end_parser
175 let true_parts = map fst parts
176 false_parts = map snd parts
177 BuildResults n cond cond_param_ops = cond_part
179 let n' = maximum $ n : map out_param_count true_parts
180 n'' = maximum $ n' : map out_param_count false_parts
182 let true_ops = map out_cap_ops true_parts
183 false_ops = map out_cap_ops false_parts
184 cond_parts = zip true_ops false_ops
186 let true_param_ops = mconcat $ map out_param_ops true_parts
187 false_param_ops = mconcat $ map out_param_ops false_parts
188 p_ops = mconcat [cond_param_ops, true_param_ops, false_param_ops]
190 return $ BuildResults n'' [ Conditional cond cond_parts ] p_ops
192 where
193 many_p !p !end = choice
194 [ try end >> return []
195 , do !v <- p
196 !vs <- many_p p end
197 return $! v : vs
198 ]
199 many_expr end = liftM mconcat $ many_p ( param_escape_parser <|> bytes_op_parser ) end
201conditional_true_parser :: CapParser ()
202conditional_true_parser = do
203 _ <- string "%t"
204 inc_offset 2
206conditional_false_parser :: CapParser ()
207conditional_false_parser = do
208 _ <- string "%e"
209 inc_offset 2
211conditional_end_parser :: CapParser ()
212conditional_end_parser = do
213 _ <- string "%;"
214 inc_offset 2
216bitwise_op_parser :: CapParser BuildResults
217bitwise_op_parser
218 = bitwise_or_parser
219 <|> bitwise_and_parser
220 <|> bitwise_xor_parser
222bitwise_or_parser :: CapParser BuildResults
223bitwise_or_parser = do
224 _ <- char '|'
225 inc_offset 1
226 return $ BuildResults 0 [ BitwiseOr ] [ ]
228bitwise_and_parser :: CapParser BuildResults
229bitwise_and_parser = do
230 _ <- char '&'
231 inc_offset 1
232 return $ BuildResults 0 [ BitwiseAnd ] [ ]
234bitwise_xor_parser :: CapParser BuildResults
235bitwise_xor_parser = do
236 _ <- char '^'
237 inc_offset 1
238 return $ BuildResults 0 [ BitwiseXOr ] [ ]
240arith_op_parser :: CapParser BuildResults
241arith_op_parser
242 = plus_op
243 <|> minus_op
244 where
245 plus_op = do
246 _ <- char '+'
247 inc_offset 1
248 return $ BuildResults 0 [ ArithPlus ] [ ]
249 minus_op = do
250 _ <- char '-'
251 inc_offset 1
252 return $ BuildResults 0 [ ArithMinus ] [ ]
254literal_int_op_parser :: CapParser BuildResults
255literal_int_op_parser = do
256 _ <- char '{'
257 inc_offset 1
258 n_str <- many1 digit
259 inc_offset $ toEnum $ length n_str
260 let n :: Word = read n_str
261 _ <- char '}'
262 inc_offset 1
263 return $ BuildResults 0 [ PushValue n ] [ ]
265compare_op_parser :: CapParser BuildResults
266compare_op_parser
267 = compare_eq_op
268 <|> compare_lt_op
269 <|> compare_gt_op
270 where
271 compare_eq_op = do
272 _ <- char '='
273 inc_offset 1
274 return $ BuildResults 0 [ CompareEq ] [ ]
275 compare_lt_op = do
276 _ <- char '<'
277 inc_offset 1
278 return $ BuildResults 0 [ CompareLt ] [ ]
279 compare_gt_op = do
280 _ <- char '>'
281 inc_offset 1
282 return $ BuildResults 0 [ CompareGt ] [ ]
284bytes_op_parser :: CapParser BuildResults
285bytes_op_parser = do
286 bytes <- many1 $ satisfy (/= '%')
287 start_offset <- getState >>= return . next_offset
288 let !c = length bytes
289 !s <- getState
290 let s' = s { next_offset = start_offset + c }
291 setState s'
292 return $ BuildResults 0 [Bytes start_offset ( toEnum c ) c ] []
294char_const_parser :: CapParser BuildResults
295char_const_parser = do
296 _ <- char '\''
297 char_value <- liftM (toEnum . fromEnum) anyChar
298 _ <- char '\''
299 inc_offset 3
300 return $ BuildResults 0 [ PushValue char_value ] [ ]
302data BuildState = BuildState
303 { next_offset :: Int
304 }
306inc_offset :: Int -> CapParser ()
307inc_offset n = do
308 s <- getState
309 let s' = s { next_offset = next_offset s + n }
310 setState s'
312initial_build_state :: BuildState
313initial_build_state = BuildState 0
315data BuildResults = BuildResults
316 { out_param_count :: !Word
317 , out_cap_ops :: !CapOps
318 , out_param_ops :: !ParamOps
319 }
321instance Monoid BuildResults where
322 mempty = BuildResults 0 [] []
323 v0 `mappend` v1
324 = BuildResults
325 { out_param_count = (out_param_count v0) `max` (out_param_count v1)
326 , out_cap_ops = (out_cap_ops v0) `mappend` (out_cap_ops v1)
327 , out_param_ops = (out_param_ops v0) `mappend` (out_param_ops v1)
328 }