{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
{-# OPTIONS_HADDOCK hide #-}

-- | Evaluates the paramaterized terminfo string capability with the
-- given parameters.
module Data.Terminfo.Eval
  ( writeCapExpr
  )
where

import Blaze.ByteString.Builder.Word
import Blaze.ByteString.Builder
import Data.Terminfo.Parse

import Control.Monad
import Control.Monad.State.Strict
import Control.Monad.Writer

import Data.Bits ((.|.), (.&.), xor)
import Data.List

import qualified Data.Vector.Unboxed as Vector

-- | capability evaluator state
data EvalState = EvalState
    { EvalState -> [CapParam]
evalStack :: ![CapParam]
    , EvalState -> CapExpression
evalExpression :: !CapExpression
    , EvalState -> [CapParam]
evalParams :: ![CapParam]
    }

type Eval a = StateT EvalState (Writer Write) a

pop :: Eval CapParam
pop :: Eval CapParam
pop = do
    s <- StateT EvalState (Writer Write) EvalState
forall s (m :: * -> *). MonadState s m => m s
get
    (v, stack') <- case evalStack s of
        [] -> [Char] -> StateT EvalState (Writer Write) (CapParam, [CapParam])
forall a. HasCallStack => [Char] -> a
error [Char]
"BUG: Data.Terminfo.Eval.pop: failed to pop from empty stack"
        CapParam
v:[CapParam]
s' -> (CapParam, [CapParam])
-> StateT EvalState (Writer Write) (CapParam, [CapParam])
forall a. a -> StateT EvalState (Writer Write) a
forall (m :: * -> *) a. Monad m => a -> m a
return (CapParam
v, [CapParam]
s')

    put $ s { evalStack = stack' }
    return v

readParam :: Word -> Eval CapParam
readParam :: CapParam -> Eval CapParam
readParam CapParam
pn = do
    !params <- EvalState -> [CapParam]
evalParams (EvalState -> [CapParam])
-> StateT EvalState (Writer Write) EvalState
-> StateT EvalState (Writer Write) [CapParam]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT EvalState (Writer Write) EvalState
forall s (m :: * -> *). MonadState s m => m s
get
    return $! genericIndex params pn

push :: CapParam -> Eval ()
push :: CapParam -> StateT EvalState (Writer Write) ()
push !CapParam
v = do
    s <- StateT EvalState (Writer Write) EvalState
forall s (m :: * -> *). MonadState s m => m s
get
    let s' = EvalState
s { evalStack = v : evalStack s }
    put s'

applyParamOps :: CapExpression -> [CapParam] -> [CapParam]
applyParamOps :: CapExpression -> [CapParam] -> [CapParam]
applyParamOps CapExpression
cap [CapParam]
params = ([CapParam] -> ParamOp -> [CapParam])
-> [CapParam] -> [ParamOp] -> [CapParam]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [CapParam] -> ParamOp -> [CapParam]
applyParamOp [CapParam]
params (CapExpression -> [ParamOp]
paramOps CapExpression
cap)

applyParamOp :: [CapParam] -> ParamOp -> [CapParam]
applyParamOp :: [CapParam] -> ParamOp -> [CapParam]
applyParamOp [CapParam]
params ParamOp
IncFirstTwo = (CapParam -> CapParam) -> [CapParam] -> [CapParam]
forall a b. (a -> b) -> [a] -> [b]
map (CapParam -> CapParam -> CapParam
forall a. Num a => a -> a -> a
+ CapParam
1) [CapParam]
params

writeCapExpr :: CapExpression -> [CapParam] -> Write
writeCapExpr :: CapExpression -> [CapParam] -> Write
writeCapExpr CapExpression
cap [CapParam]
params =
    let params' :: [CapParam]
params' = CapExpression -> [CapParam] -> [CapParam]
applyParamOps CapExpression
cap [CapParam]
params
        s0 :: EvalState
s0 = [CapParam] -> CapExpression -> [CapParam] -> EvalState
EvalState [] CapExpression
cap [CapParam]
params'
    in (((), EvalState), Write) -> Write
forall a b. (a, b) -> b
snd ((((), EvalState), Write) -> Write)
-> (((), EvalState), Write) -> Write
forall a b. (a -> b) -> a -> b
$ Writer Write ((), EvalState) -> (((), EvalState), Write)
forall w a. Writer w a -> (a, w)
runWriter (StateT EvalState (Writer Write) ()
-> EvalState -> Writer Write ((), EvalState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (CapOps -> StateT EvalState (Writer Write) ()
writeCapOps (CapExpression -> CapOps
capOps CapExpression
cap)) EvalState
s0)

writeCapOps :: CapOps -> Eval ()
writeCapOps :: CapOps -> StateT EvalState (Writer Write) ()
writeCapOps = (CapOp -> StateT EvalState (Writer Write) ())
-> CapOps -> StateT EvalState (Writer Write) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CapOp -> StateT EvalState (Writer Write) ()
writeCapOp

writeCapOp :: CapOp -> Eval ()
writeCapOp :: CapOp -> StateT EvalState (Writer Write) ()
writeCapOp (Bytes !Int
offset !Int
count) = do
    !cap <- EvalState -> CapExpression
evalExpression (EvalState -> CapExpression)
-> StateT EvalState (Writer Write) EvalState
-> StateT EvalState (Writer Write) CapExpression
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT EvalState (Writer Write) EvalState
forall s (m :: * -> *). MonadState s m => m s
get
    let bytes = Int -> Vector Word8 -> Vector Word8
forall a. Unbox a => Int -> Vector a -> Vector a
Vector.take Int
count (Vector Word8 -> Vector Word8) -> Vector Word8 -> Vector Word8
forall a b. (a -> b) -> a -> b
$ Int -> Vector Word8 -> Vector Word8
forall a. Unbox a => Int -> Vector a -> Vector a
Vector.drop Int
offset (CapExpression -> Vector Word8
capBytes CapExpression
cap)
    Vector.forM_ bytes $ tell.writeWord8
writeCapOp CapOp
DecOut = do
    p <- Eval CapParam
pop
    forM_ (show p) $ tell.writeWord8.toEnum.fromEnum
writeCapOp CapOp
CharOut = do
    Eval CapParam
pop Eval CapParam
-> (CapParam -> StateT EvalState (Writer Write) ())
-> StateT EvalState (Writer Write) ()
forall a b.
StateT EvalState (Writer Write) a
-> (a -> StateT EvalState (Writer Write) b)
-> StateT EvalState (Writer Write) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Write -> StateT EvalState (Writer Write) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell(Write -> StateT EvalState (Writer Write) ())
-> (CapParam -> Write)
-> CapParam
-> StateT EvalState (Writer Write) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Word8 -> Write
writeWord8(Word8 -> Write) -> (CapParam -> Word8) -> CapParam -> Write
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Int -> Word8
forall a. Enum a => Int -> a
toEnum(Int -> Word8) -> (CapParam -> Int) -> CapParam -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
.CapParam -> Int
forall a. Enum a => a -> Int
fromEnum
writeCapOp (PushParam CapParam
pn) = do
    CapParam -> Eval CapParam
readParam CapParam
pn Eval CapParam
-> (CapParam -> StateT EvalState (Writer Write) ())
-> StateT EvalState (Writer Write) ()
forall a b.
StateT EvalState (Writer Write) a
-> (a -> StateT EvalState (Writer Write) b)
-> StateT EvalState (Writer Write) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= CapParam -> StateT EvalState (Writer Write) ()
push
writeCapOp (PushValue CapParam
v) = do
    CapParam -> StateT EvalState (Writer Write) ()
push CapParam
v
writeCapOp (Conditional CapOps
expr [(CapOps, CapOps)]
parts) = do
    CapOps -> StateT EvalState (Writer Write) ()
writeCapOps CapOps
expr
    [(CapOps, CapOps)] -> StateT EvalState (Writer Write) ()
writeContitionalParts [(CapOps, CapOps)]
parts
    where
        writeContitionalParts :: [(CapOps, CapOps)] -> StateT EvalState (Writer Write) ()
writeContitionalParts [] = () -> StateT EvalState (Writer Write) ()
forall a. a -> StateT EvalState (Writer Write) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        writeContitionalParts ((CapOps
trueOps, CapOps
falseOps) : [(CapOps, CapOps)]
falseParts) = do
            -- (man 5 terminfo)
            -- Usually the %? expr part pushes a value onto the stack,
            -- and %t pops it from the stack, testing if it is nonzero
            -- (true). If it is zero (false), control passes to the %e
            -- (else) part.
            v <- Eval CapParam
pop
            if v /= 0
                then writeCapOps trueOps
                else do
                    writeCapOps falseOps
                    writeContitionalParts falseParts

writeCapOp CapOp
BitwiseOr = do
    v0 <- Eval CapParam
pop
    v1 <- pop
    push $ v0 .|. v1
writeCapOp CapOp
BitwiseAnd = do
    v0 <- Eval CapParam
pop
    v1 <- pop
    push $ v0 .&. v1
writeCapOp CapOp
BitwiseXOr = do
    v1 <- Eval CapParam
pop
    v0 <- pop
    push $ v0 `xor` v1
writeCapOp CapOp
ArithPlus = do
    v1 <- Eval CapParam
pop
    v0 <- pop
    push $ v0 + v1
writeCapOp CapOp
ArithMinus = do
    v1 <- Eval CapParam
pop
    v0 <- pop
    push $ v0 - v1
writeCapOp CapOp
CompareEq = do
    v1 <- Eval CapParam
pop
    v0 <- pop
    push $ if v0 == v1 then 1 else 0
writeCapOp CapOp
CompareLt = do
    v1 <- Eval CapParam
pop
    v0 <- pop
    push $ if v0 < v1 then 1 else 0
writeCapOp CapOp
CompareGt = do
    v1 <- Eval CapParam
pop
    v0 <- pop
    push $ if v0 > v1 then 1 else 0