{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# OPTIONS_GHC -funbox-strict-fields #-}
{-# OPTIONS_HADDOCK hide #-}
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
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
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