git.iko.soy/vty
on ae06339 help sign in
vty/src/Data/Terminfo/Parse.hs
341 lines 10 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.DeepSeq
17import Data.Monoid
18import Data.Word
20import Foreign.C.Types
21import Foreign.Marshal.Array
22import Foreign.Ptr
24import Text.ParserCombinators.Parsec
26type CapBytes = ( Ptr Word8, CSize )
28data CapExpression = CapExpression
29 { cap_ops :: !CapOps
30 , cap_bytes :: !CapBytes
31 , source_string :: !String
32 , param_count :: !Word
33 , param_ops :: !ParamOps
34 }
36instance NFData CapExpression where
37 rnf (CapExpression ops !_bytes !str !c !p_ops)
38 = rnf ops `seq` rnf str `seq` rnf c `seq` rnf p_ops
40type CapParam = Word
42type CapOps = [CapOp]
43data CapOp =
44 Bytes !Int !CSize !Int
45 | DecOut | CharOut
46 -- This stores a 0-based index to the parameter. However the operation that implies this op is
47 -- 1-based
48 | PushParam !Word | PushValue !Word
49 -- The conditional parts are the sequence of (%t expression, %e expression) pairs.
50 -- The %e expression may be NOP
51 | Conditional
52 { conditional_expr :: !CapOps
53 , conditional_parts :: ![(CapOps, CapOps)]
54 }
55 | BitwiseOr | BitwiseXOr | BitwiseAnd
56 | ArithPlus | ArithMinus
57 | CompareEq | CompareLt | CompareGt
58 deriving ( Show )
60instance NFData CapOp where
61 rnf (Bytes offset _count next_offset) = rnf offset `seq` rnf next_offset
62 rnf (PushParam pn) = rnf pn
63 rnf (PushValue v) = rnf v
64 rnf (Conditional c_expr c_parts) = rnf c_expr `seq` rnf c_parts
65 rnf BitwiseOr = ()
66 rnf BitwiseXOr = ()
67 rnf BitwiseAnd = ()
68 rnf ArithPlus = ()
69 rnf ArithMinus = ()
70 rnf CompareEq = ()
71 rnf CompareLt = ()
72 rnf CompareGt = ()
73 rnf DecOut = ()
74 rnf CharOut = ()
76type ParamOps = [ParamOp]
77data ParamOp =
78 IncFirstTwo
79 deriving ( Show )
81instance NFData ParamOp where
82 rnf IncFirstTwo = ()
84parse_cap_expression :: ( Applicative m
85 , MonadIO m
86 )
87 => String
88 -> m ( Either ParseError CapExpression )
89parse_cap_expression cap_string =
90 let v = runParser cap_expression_parser
91 initial_build_state
92 "terminfo cap"
93 cap_string
94 in case v of
95 Left e -> return $ Left e
96 Right build_results -> pure Right <*> construct_cap_expression cap_string build_results
98construct_cap_expression :: MonadIO m => [Char] -> BuildResults -> m CapExpression
99construct_cap_expression cap_string build_results = do
100 byte_array <- liftIO $ newArray (map ( toEnum . fromEnum ) cap_string )
101 let expr = CapExpression
102 { cap_ops = out_cap_ops build_results
103 -- The cap bytes are the lower 8 bits of the input string's characters.
104 -- \todo Verify the input string actually contains an 8bit byte per character.
105 , cap_bytes = ( byte_array, toEnum $! length cap_string )
106 , source_string = cap_string
107 , param_count = out_param_count build_results
108 , param_ops = out_param_ops build_results
109 }
110 return $! rnf expr `seq` expr
112type CapParser a = GenParser Char BuildState a
114cap_expression_parser :: CapParser BuildResults
115cap_expression_parser = do
116 rs <- many $ param_escape_parser <|> bytes_op_parser
117 return $ mconcat rs
119param_escape_parser :: CapParser BuildResults
120param_escape_parser = do
121 _ <- char '%'
122 inc_offset 1
123 literal_percent_parser <|> param_op_parser
125literal_percent_parser :: CapParser BuildResults
126literal_percent_parser = do
127 _ <- char '%'
128 start_offset <- getState >>= return . next_offset
129 inc_offset 1
130 return $ BuildResults 0 [Bytes start_offset 1 1] []
132param_op_parser :: CapParser BuildResults
133param_op_parser
134 = increment_op_parser
135 <|> push_op_parser
136 <|> dec_out_parser
137 <|> char_out_parser
138 <|> conditional_op_parser
139 <|> bitwise_op_parser
140 <|> arith_op_parser
141 <|> literal_int_op_parser
142 <|> compare_op_parser
143 <|> char_const_parser
145increment_op_parser :: CapParser BuildResults
146increment_op_parser = do
147 _ <- char 'i'
148 inc_offset 1
149 return $ BuildResults 0 [] [ IncFirstTwo ]
151push_op_parser :: CapParser BuildResults
152push_op_parser = do
153 _ <- char 'p'
154 param_n <- digit >>= return . (\d -> read [d])
155 inc_offset 2
156 return $ BuildResults param_n [ PushParam $ param_n - 1 ] []
158dec_out_parser :: CapParser BuildResults
159dec_out_parser = do
160 _ <- char 'd'
161 inc_offset 1
162 return $ BuildResults 0 [ DecOut ] []
164char_out_parser :: CapParser BuildResults
165char_out_parser = do
166 _ <- char 'c'
167 inc_offset 1
168 return $ BuildResults 0 [ CharOut ] []
170conditional_op_parser :: CapParser BuildResults
171conditional_op_parser = do
172 _ <- char '?'
173 inc_offset 1
174 cond_part <- many_expr conditional_true_parser
175 parts <- many_p
176 ( do
177 true_part <- many_expr $ choice [ try $ lookAhead conditional_end_parser
178 , conditional_false_parser
179 ]
180 false_part <- many_expr $ choice [ try $ lookAhead conditional_end_parser
181 , conditional_true_parser
182 ]
183 return ( true_part, false_part )
184 )
185 conditional_end_parser
187 let true_parts = map fst parts
188 false_parts = map snd parts
189 BuildResults n cond cond_param_ops = cond_part
191 let n' = maximum $ n : map out_param_count true_parts
192 n'' = maximum $ n' : map out_param_count false_parts
194 let true_ops = map out_cap_ops true_parts
195 false_ops = map out_cap_ops false_parts
196 cond_parts = zip true_ops false_ops
198 let true_param_ops = mconcat $ map out_param_ops true_parts
199 false_param_ops = mconcat $ map out_param_ops false_parts
200 p_ops = mconcat [cond_param_ops, true_param_ops, false_param_ops]
202 return $ BuildResults n'' [ Conditional cond cond_parts ] p_ops
204 where
205 many_p !p !end = choice
206 [ try end >> return []
207 , do !v <- p
208 !vs <- many_p p end
209 return $! v : vs
210 ]
211 many_expr end = liftM mconcat $ many_p ( param_escape_parser <|> bytes_op_parser ) end
213conditional_true_parser :: CapParser ()
214conditional_true_parser = do
215 _ <- string "%t"
216 inc_offset 2
218conditional_false_parser :: CapParser ()
219conditional_false_parser = do
220 _ <- string "%e"
221 inc_offset 2
223conditional_end_parser :: CapParser ()
224conditional_end_parser = do
225 _ <- string "%;"
226 inc_offset 2
228bitwise_op_parser :: CapParser BuildResults
229bitwise_op_parser
230 = bitwise_or_parser
231 <|> bitwise_and_parser
232 <|> bitwise_xor_parser
234bitwise_or_parser :: CapParser BuildResults
235bitwise_or_parser = do
236 _ <- char '|'
237 inc_offset 1
238 return $ BuildResults 0 [ BitwiseOr ] [ ]
240bitwise_and_parser :: CapParser BuildResults
241bitwise_and_parser = do
242 _ <- char '&'
243 inc_offset 1
244 return $ BuildResults 0 [ BitwiseAnd ] [ ]
246bitwise_xor_parser :: CapParser BuildResults
247bitwise_xor_parser = do
248 _ <- char '^'
249 inc_offset 1
250 return $ BuildResults 0 [ BitwiseXOr ] [ ]
252arith_op_parser :: CapParser BuildResults
253arith_op_parser
254 = plus_op
255 <|> minus_op
256 where
257 plus_op = do
258 _ <- char '+'
259 inc_offset 1
260 return $ BuildResults 0 [ ArithPlus ] [ ]
261 minus_op = do
262 _ <- char '-'
263 inc_offset 1
264 return $ BuildResults 0 [ ArithMinus ] [ ]
266literal_int_op_parser :: CapParser BuildResults
267literal_int_op_parser = do
268 _ <- char '{'
269 inc_offset 1
270 n_str <- many1 digit
271 inc_offset $ toEnum $ length n_str
272 let n :: Word = read n_str
273 _ <- char '}'
274 inc_offset 1
275 return $ BuildResults 0 [ PushValue n ] [ ]
277compare_op_parser :: CapParser BuildResults
278compare_op_parser
279 = compare_eq_op
280 <|> compare_lt_op
281 <|> compare_gt_op
282 where
283 compare_eq_op = do
284 _ <- char '='
285 inc_offset 1
286 return $ BuildResults 0 [ CompareEq ] [ ]
287 compare_lt_op = do
288 _ <- char '<'
289 inc_offset 1
290 return $ BuildResults 0 [ CompareLt ] [ ]
291 compare_gt_op = do
292 _ <- char '>'
293 inc_offset 1
294 return $ BuildResults 0 [ CompareGt ] [ ]
296bytes_op_parser :: CapParser BuildResults
297bytes_op_parser = do
298 bytes <- many1 $ satisfy (/= '%')
299 start_offset <- getState >>= return . next_offset
300 let !c = length bytes
301 !s <- getState
302 let s' = s { next_offset = start_offset + c }
303 setState s'
304 return $ BuildResults 0 [Bytes start_offset ( toEnum c ) c ] []
306char_const_parser :: CapParser BuildResults
307char_const_parser = do
308 _ <- char '\''
309 char_value <- liftM (toEnum . fromEnum) anyChar
310 _ <- char '\''
311 inc_offset 3
312 return $ BuildResults 0 [ PushValue char_value ] [ ]
314data BuildState = BuildState
315 { next_offset :: Int
316 }
318inc_offset :: Int -> CapParser ()
319inc_offset n = do
320 s <- getState
321 let s' = s { next_offset = next_offset s + n }
322 setState s'
324initial_build_state :: BuildState
325initial_build_state = BuildState 0
327data BuildResults = BuildResults
328 { out_param_count :: !Word
329 , out_cap_ops :: !CapOps
330 , out_param_ops :: !ParamOps
331 }
333instance Monoid BuildResults where
334 mempty = BuildResults 0 [] []
335 v0 `mappend` v1
336 = BuildResults
337 { out_param_count = (out_param_count v0) `max` (out_param_count v1)
338 , out_cap_ops = (out_cap_ops v0) `mappend` (out_cap_ops v1)
339 , out_param_ops = (out_param_ops v0) `mappend` (out_param_ops v1)
340 }