1{-# LANGUAGE BangPatterns #-} 2{-# LANGUAGE NoMonomorphismRestriction #-} 3{-# OPTIONS_GHC -funbox-strict-fields #-} 4{-# OPTIONS_HADDOCK hide #-} 5 6-- | Evaluates the paramaterized terminfo string capability with the 7-- given parameters. 8module Data.Terminfo.Eval 9 ( writeCapExpr 10 ) 11where 12 13import Blaze.ByteString.Builder.Word 14import Blaze.ByteString.Builder 15import Data.Terminfo.Parse 16 17import Control.Monad.Identity 18import Control.Monad.State.Strict 19import Control.Monad.Writer 20 21import Data.Bits ((.|.), (.&.), xor) 22import Data.List 23 24import qualified Data.Vector.Unboxed as Vector 25 26-- | capability evaluator state 27data EvalState = EvalState 28 { evalStack :: ![CapParam] 29 , evalExpression :: !CapExpression 30 , evalParams :: ![CapParam] 31 } 32 33type Eval a = StateT EvalState (Writer Write) a 34 35pop :: Eval CapParam 36pop = do 37 s <- get 38 let v : stack' = evalStack s 39 s' = s { evalStack = stack' } 40 put s' 41 return v 42 43readParam :: Word -> Eval CapParam 44readParam pn = do 45 !params <- evalParams <$> get 46 return $! genericIndex params pn 47 48push :: CapParam -> Eval () 49push !v = do 50 s <- get 51 let s' = s { evalStack = v : evalStack s } 52 put s' 53 54applyParamOps :: CapExpression -> [CapParam] -> [CapParam] 55applyParamOps cap params = foldl applyParamOp params (paramOps cap) 56 57applyParamOp :: [CapParam] -> ParamOp -> [CapParam] 58applyParamOp params IncFirstTwo = map (+ 1) params 59 60writeCapExpr :: CapExpression -> [CapParam] -> Write 61writeCapExpr cap params = 62 let params' = applyParamOps cap params 63 s0 = EvalState [] cap params' 64 in snd $ runWriter (runStateT (writeCapOps (capOps cap)) s0) 65 66writeCapOps :: CapOps -> Eval () 67writeCapOps = mapM_ writeCapOp 68 69writeCapOp :: CapOp -> Eval () 70writeCapOp (Bytes !offset !count) = do 71 !cap <- evalExpression <$> get 72 let bytes = Vector.take count $ Vector.drop offset (capBytes cap) 73 Vector.forM_ bytes $ tell.writeWord8 74writeCapOp DecOut = do 75 p <- pop 76 forM_ (show p) $ tell.writeWord8.toEnum.fromEnum 77writeCapOp CharOut = do 78 pop >>= tell.writeWord8.toEnum.fromEnum 79writeCapOp (PushParam pn) = do 80 readParam pn >>= push 81writeCapOp (PushValue v) = do 82 push v 83writeCapOp (Conditional expr parts) = do 84 writeCapOps expr 85 writeContitionalParts parts 86 where 87 writeContitionalParts [] = return () 88 writeContitionalParts ((trueOps, falseOps) : falseParts) = do 89 -- (man 5 terminfo) 90 -- Usually the %? expr part pushes a value onto the stack, 91 -- and %t pops it from the stack, testing if it is nonzero 92 -- (true). If it is zero (false), control passes to the %e 93 -- (else) part. 94 v <- pop 95 if v /= 0 96 then writeCapOps trueOps 97 else do 98 writeCapOps falseOps 99 writeContitionalParts falseParts 100 101writeCapOp BitwiseOr = do 102 v0 <- pop 103 v1 <- pop 104 push $ v0 .|. v1 105writeCapOp BitwiseAnd = do 106 v0 <- pop 107 v1 <- pop 108 push $ v0 .&. v1 109writeCapOp BitwiseXOr = do 110 v1 <- pop 111 v0 <- pop 112 push $ v0 `xor` v1 113writeCapOp ArithPlus = do 114 v1 <- pop 115 v0 <- pop 116 push $ v0 + v1 117writeCapOp ArithMinus = do 118 v1 <- pop 119 v0 <- pop 120 push $ v0 - v1 121writeCapOp CompareEq = do 122 v1 <- pop 123 v0 <- pop 124 push $ if v0 == v1 then 1 else 0 125writeCapOp CompareLt = do 126 v1 <- pop 127 v0 <- pop 128 push $ if v0 < v1 then 1 else 0 129writeCapOp CompareGt = do 130 v1 <- pop 131 v0 <- pop 132 push $ if v0 > v1 then 1 else 0 133