module Data.Terminfo.Eval ( cap_expression_required_bytes
, serialize_cap_expression
)
where
import Data.ByteString.Internal ( memcpy )
import Data.Marshalling
import Data.Terminfo.Parse
import Control.Monad.Identity
import Control.Monad.State.Strict
import Data.Bits ( (.|.), (.&.), xor )
import Data.List
import GHC.Prim
import GHC.Word
data EvalState = EvalState
{ eval_stack :: ![ CapParam ]
, eval_expression :: !CapExpression
, eval_params :: ![ CapParam ]
}
type EvalT m a = StateT EvalState m a
type Eval a = EvalT Identity a
pop :: Monad m => EvalT m CapParam
pop = do
s <- get
let v : stack' = eval_stack s
s' = s { eval_stack = stack' }
put s'
return v
read_param :: Monad m => Word -> EvalT m CapParam
read_param pn = do
!params <- get >>= return . eval_params
return $! genericIndex params pn
push :: Monad m => CapParam -> EvalT m ()
push !v = do
s <- get
let s' = s { eval_stack = v : eval_stack s }
put s'
apply_param_ops :: CapExpression -> [CapParam] -> [CapParam]
apply_param_ops cap params = foldl apply_param_op params (param_ops cap)
apply_param_op :: [CapParam] -> ParamOp -> [CapParam]
apply_param_op params IncFirstTwo = map (+ 1) params
cap_expression_required_bytes :: CapExpression -> [CapParam] -> Word
cap_expression_required_bytes cap params =
let params' = apply_param_ops cap params
s_0 = EvalState [] cap params'
in fst $! runIdentity $! runStateT ( cap_ops_required_bytes $! cap_ops cap ) s_0
cap_ops_required_bytes :: CapOps -> Eval Word
cap_ops_required_bytes ops = do
counts <- mapM cap_op_required_bytes ops
return $ sum counts
cap_op_required_bytes :: CapOp -> Eval Word
cap_op_required_bytes (Bytes _ _ c) = return $ toEnum c
cap_op_required_bytes DecOut = do
p <- pop
return $ toEnum $ length $ show p
cap_op_required_bytes CharOut = do
_ <- pop
return 1
cap_op_required_bytes (PushParam pn) = do
read_param pn >>= push
return 0
cap_op_required_bytes (PushValue v) = do
push v
return 0
cap_op_required_bytes (Conditional expr parts) = do
c_expr <- cap_ops_required_bytes expr
c_parts <- cond_parts_required_bytes parts
return $ c_expr + c_parts
where
cond_parts_required_bytes [] = return 0
cond_parts_required_bytes ( (true_ops, false_ops) : false_parts ) = do
v <- pop
c_total <- if v /= 0
then cap_ops_required_bytes true_ops
else do
c_false <- cap_ops_required_bytes false_ops
c_remain <- cond_parts_required_bytes false_parts
return $ c_false + c_remain
return c_total
cap_op_required_bytes BitwiseOr = do
v_1 <- pop
v_0 <- pop
push $ v_0 .|. v_1
return 0
cap_op_required_bytes BitwiseAnd = do
v_1 <- pop
v_0 <- pop
push $ v_0 .&. v_1
return 0
cap_op_required_bytes BitwiseXOr = do
v_1 <- pop
v_0 <- pop
push $ v_0 `xor` v_1
return 0
cap_op_required_bytes ArithPlus = do
v_1 <- pop
v_0 <- pop
push $ v_0 + v_1
return 0
cap_op_required_bytes ArithMinus = do
v_1 <- pop
v_0 <- pop
push $ v_0 v_1
return 0
cap_op_required_bytes CompareEq = do
v_1 <- pop
v_0 <- pop
push $ if v_0 == v_1 then 1 else 0
return 0
cap_op_required_bytes CompareLt = do
v_1 <- pop
v_0 <- pop
push $ if v_0 < v_1 then 1 else 0
return 0
cap_op_required_bytes CompareGt = do
v_1 <- pop
v_0 <- pop
push $ if v_0 > v_1 then 1 else 0
return 0
serialize_cap_expression :: CapExpression -> [CapParam] -> OutputBuffer -> IO OutputBuffer
serialize_cap_expression cap params out_ptr = do
let params' = apply_param_ops cap params
s_0 = EvalState [] cap params'
(!out_ptr', _) <- runStateT ( serialize_cap_ops out_ptr (cap_ops cap) ) s_0
return $! out_ptr'
serialize_cap_ops :: OutputBuffer -> CapOps -> EvalT IO OutputBuffer
serialize_cap_ops out_ptr ops = foldM serialize_cap_op out_ptr ops
serialize_cap_op :: OutputBuffer -> CapOp -> EvalT IO OutputBuffer
serialize_cap_op !out_ptr ( Bytes !offset !byte_count !next_offset ) = do
!cap <- get >>= return . eval_expression
let ( !start_ptr, _ ) = cap_bytes cap
!src_ptr = start_ptr `plusPtr` offset
!out_ptr' = out_ptr `plusPtr` next_offset
liftIO $! memcpy out_ptr src_ptr byte_count
return $! out_ptr'
serialize_cap_op out_ptr DecOut = do
p <- pop
let out_str = show p
out_bytes = string_to_bytes out_str
serialize_bytes out_bytes out_ptr
serialize_cap_op out_ptr CharOut = do
W# p <- pop
let !out_byte = W8# (and# p 0xFF##)
!out_ptr' = out_ptr `plusPtr` 1
liftIO $ poke out_ptr out_byte
return out_ptr'
serialize_cap_op out_ptr (PushParam pn) = do
read_param pn >>= push
return out_ptr
serialize_cap_op out_ptr (PushValue v) = do
push v
return out_ptr
serialize_cap_op out_ptr (Conditional expr parts) = do
out_ptr' <- serialize_cap_ops out_ptr expr
out_ptr'' <- serialize_cond_parts out_ptr' parts
return out_ptr''
where
serialize_cond_parts ptr [] = return ptr
serialize_cond_parts ptr ( (true_ops, false_ops) : false_parts ) = do
v <- pop
ptr'' <- if v /= 0
then serialize_cap_ops ptr true_ops
else do
ptr' <- serialize_cap_ops ptr false_ops
serialize_cond_parts ptr' false_parts
return ptr''
serialize_cap_op out_ptr BitwiseOr = do
v_0 <- pop
v_1 <- pop
push $ v_0 .|. v_1
return out_ptr
serialize_cap_op out_ptr BitwiseAnd = do
v_0 <- pop
v_1 <- pop
push $ v_0 .&. v_1
return out_ptr
serialize_cap_op out_ptr BitwiseXOr = do
v_1 <- pop
v_0 <- pop
push $ v_0 `xor` v_1
return out_ptr
serialize_cap_op out_ptr ArithPlus = do
v_1 <- pop
v_0 <- pop
push $ v_0 + v_1
return out_ptr
serialize_cap_op out_ptr ArithMinus = do
v_1 <- pop
v_0 <- pop
push $ v_0 v_1
return out_ptr
serialize_cap_op out_ptr CompareEq = do
v_1 <- pop
v_0 <- pop
push $ if v_0 == v_1 then 1 else 0
return out_ptr
serialize_cap_op out_ptr CompareLt = do
v_1 <- pop
v_0 <- pop
push $ if v_0 < v_1 then 1 else 0
return out_ptr
serialize_cap_op out_ptr CompareGt = do
v_1 <- pop
v_0 <- pop
push $ if v_0 > v_1 then 1 else 0
return out_ptr