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