{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StrictData                 #-}
module Language.GLSL.Runtime.Value where

import           Control.Monad.Trans.State.Strict (StateT)
import qualified Data.IntMap                      as M
import           Language.GLSL.AST                (BinaryOp (..), ParamDecl,
                                                   StmtAnnot, Type (..),
                                                   UnaryOp (..))
import           Language.GLSL.Decls              (Decls)
import           Language.GLSL.PrettyPrint        (pp, ppType)
import           Linear                           (M44, V2, V3, V4, (!*!), (!*))

data Proc
  = Proc [ParamDecl] [StmtAnnot ()]

data EvalState = EvalState
  { EvalState -> IntMap Proc
stProcs     :: M.IntMap Proc
  , EvalState -> Maybe Proc
stMainProc  :: Maybe Proc

  , EvalState -> Decls Value
globals     :: Decls Value
  , EvalState -> Maybe Value
gl_Position :: Maybe Value
  }

newtype EvalResult a = EvalResult { EvalResult a -> Either String a
fromResult :: Either String a }
  deriving (a -> EvalResult b -> EvalResult a
(a -> b) -> EvalResult a -> EvalResult b
(forall a b. (a -> b) -> EvalResult a -> EvalResult b)
-> (forall a b. a -> EvalResult b -> EvalResult a)
-> Functor EvalResult
forall a b. a -> EvalResult b -> EvalResult a
forall a b. (a -> b) -> EvalResult a -> EvalResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> EvalResult b -> EvalResult a
$c<$ :: forall a b. a -> EvalResult b -> EvalResult a
fmap :: (a -> b) -> EvalResult a -> EvalResult b
$cfmap :: forall a b. (a -> b) -> EvalResult a -> EvalResult b
Functor, Functor EvalResult
a -> EvalResult a
Functor EvalResult
-> (forall a. a -> EvalResult a)
-> (forall a b.
    EvalResult (a -> b) -> EvalResult a -> EvalResult b)
-> (forall a b c.
    (a -> b -> c) -> EvalResult a -> EvalResult b -> EvalResult c)
-> (forall a b. EvalResult a -> EvalResult b -> EvalResult b)
-> (forall a b. EvalResult a -> EvalResult b -> EvalResult a)
-> Applicative EvalResult
EvalResult a -> EvalResult b -> EvalResult b
EvalResult a -> EvalResult b -> EvalResult a
EvalResult (a -> b) -> EvalResult a -> EvalResult b
(a -> b -> c) -> EvalResult a -> EvalResult b -> EvalResult c
forall a. a -> EvalResult a
forall a b. EvalResult a -> EvalResult b -> EvalResult a
forall a b. EvalResult a -> EvalResult b -> EvalResult b
forall a b. EvalResult (a -> b) -> EvalResult a -> EvalResult b
forall a b c.
(a -> b -> c) -> EvalResult a -> EvalResult b -> EvalResult c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: EvalResult a -> EvalResult b -> EvalResult a
$c<* :: forall a b. EvalResult a -> EvalResult b -> EvalResult a
*> :: EvalResult a -> EvalResult b -> EvalResult b
$c*> :: forall a b. EvalResult a -> EvalResult b -> EvalResult b
liftA2 :: (a -> b -> c) -> EvalResult a -> EvalResult b -> EvalResult c
$cliftA2 :: forall a b c.
(a -> b -> c) -> EvalResult a -> EvalResult b -> EvalResult c
<*> :: EvalResult (a -> b) -> EvalResult a -> EvalResult b
$c<*> :: forall a b. EvalResult (a -> b) -> EvalResult a -> EvalResult b
pure :: a -> EvalResult a
$cpure :: forall a. a -> EvalResult a
$cp1Applicative :: Functor EvalResult
Applicative, Applicative EvalResult
a -> EvalResult a
Applicative EvalResult
-> (forall a b.
    EvalResult a -> (a -> EvalResult b) -> EvalResult b)
-> (forall a b. EvalResult a -> EvalResult b -> EvalResult b)
-> (forall a. a -> EvalResult a)
-> Monad EvalResult
EvalResult a -> (a -> EvalResult b) -> EvalResult b
EvalResult a -> EvalResult b -> EvalResult b
forall a. a -> EvalResult a
forall a b. EvalResult a -> EvalResult b -> EvalResult b
forall a b. EvalResult a -> (a -> EvalResult b) -> EvalResult b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> EvalResult a
$creturn :: forall a. a -> EvalResult a
>> :: EvalResult a -> EvalResult b -> EvalResult b
$c>> :: forall a b. EvalResult a -> EvalResult b -> EvalResult b
>>= :: EvalResult a -> (a -> EvalResult b) -> EvalResult b
$c>>= :: forall a b. EvalResult a -> (a -> EvalResult b) -> EvalResult b
$cp1Monad :: Applicative EvalResult
Monad)

instance MonadFail EvalResult where
  fail :: String -> EvalResult a
fail = Either String a -> EvalResult a
forall a. Either String a -> EvalResult a
EvalResult (Either String a -> EvalResult a)
-> (String -> Either String a) -> String -> EvalResult a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Either String a
forall a b. a -> Either a b
Left

type Eval = StateT EvalState EvalResult

data Value
  = FloatValue Float
  | IntValue Int
  | BoolValue Bool
  | Vec2Value (V2 Float)
  | Vec3Value (V3 Float)
  | Vec4Value (V4 Float)
  | Mat4x4Value (M44 Float)
  deriving (Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show, Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c== :: Value -> Value -> Bool
Eq)


defaultValue :: Type -> Value
defaultValue :: Type -> Value
defaultValue Type
TyFloat   = Float -> Value
FloatValue Float
0
defaultValue (TyVec Int
2) = V2 Float -> Value
Vec2Value V2 Float
0
defaultValue (TyVec Int
3) = V3 Float -> Value
Vec3Value V3 Float
0
defaultValue (TyVec Int
4) = V4 Float -> Value
Vec4Value V4 Float
0
defaultValue Type
ty        = String -> Value
forall a. HasCallStack => String -> a
error (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ String
"defaultValue not implemented: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Type -> Builder) -> Type -> String
forall a. (a -> Builder) -> a -> String
pp Type -> Builder
ppType Type
ty


isNaNValue :: Value -> Bool
isNaNValue :: Value -> Bool
isNaNValue (FloatValue Float
v) = Float -> Bool
forall a. RealFloat a => a -> Bool
isNaN Float
v
isNaNValue Value
_              = Bool
False


roundValue :: Value -> Value
roundValue :: Value -> Value
roundValue (FloatValue Float
v) =
  Float -> Value
FloatValue (Float -> Value) -> Float -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Float -> Integer
forall a b. (RealFrac a, Integral b) => a -> b
round (Float
v Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float
100000) :: Integer) Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
100000
roundValue Value
v = Value
v


evalCoerce :: Type -> Value -> Eval Value
evalCoerce :: Type -> Value -> Eval Value
evalCoerce Type
TyFloat v :: Value
v@FloatValue{} = Value -> Eval Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
evalCoerce Type
TyBool v :: Value
v@BoolValue{} = Value -> Eval Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
evalCoerce Type
TyFloat (IntValue Int
i)   = Value -> Eval Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> Eval Value) -> Value -> Eval Value
forall a b. (a -> b) -> a -> b
$ Float -> Value
FloatValue (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i)
evalCoerce (TyVec Int
2) v :: Value
v@Vec2Value{}     = Value -> Eval Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
evalCoerce (TyVec Int
3) v :: Value
v@Vec3Value{}     = Value -> Eval Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
evalCoerce (TyVec Int
4) v :: Value
v@Vec4Value{}     = Value -> Eval Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
evalCoerce (TyMat Int
4 Int
4) v :: Value
v@Mat4x4Value{} = Value -> Eval Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
evalCoerce Type
ty Value
v                        = String -> Eval Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Eval Value) -> String -> Eval Value
forall a b. (a -> b) -> a -> b
$ String
"coerce failed: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Type, Value) -> String
forall a. Show a => a -> String
show (Type
ty, Value
v)


evalBinaryOp :: Value -> BinaryOp -> Value -> Value
evalBinaryOp :: Value -> BinaryOp -> Value -> Value
evalBinaryOp (FloatValue Float
l) BinaryOp
BOpPlus (FloatValue Float
r)  = Float -> Value
FloatValue (Float
l Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
r)
evalBinaryOp (FloatValue Float
l) BinaryOp
BOpMinus (FloatValue Float
r) = Float -> Value
FloatValue (Float
l Float -> Float -> Float
forall a. Num a => a -> a -> a
- Float
r)
evalBinaryOp (FloatValue Float
l) BinaryOp
BOpMul (FloatValue Float
r)   = Float -> Value
FloatValue (Float
l Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
r)
evalBinaryOp (FloatValue Float
l) BinaryOp
BOpDiv (FloatValue Float
r)   = Float -> Value
FloatValue (Float
l Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
r)
evalBinaryOp (FloatValue Float
l) BinaryOp
BOpLE (FloatValue Float
r)    = Bool -> Value
BoolValue (Float
l Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
<= Float
r)
evalBinaryOp (FloatValue Float
l) BinaryOp
BOpGE (FloatValue Float
r)    = Bool -> Value
BoolValue (Float
l Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
>= Float
r)
evalBinaryOp (FloatValue Float
l) BinaryOp
BOpLT (FloatValue Float
r)    = Bool -> Value
BoolValue (Float
l Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
< Float
r)
evalBinaryOp (FloatValue Float
l) BinaryOp
BOpGT (FloatValue Float
r)    = Bool -> Value
BoolValue (Float
l Float -> Float -> Bool
forall a. Ord a => a -> a -> Bool
> Float
r)

evalBinaryOp (IntValue Int
l) BinaryOp
BOpPlus (IntValue Int
r)      = Int -> Value
IntValue (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
r)
evalBinaryOp (IntValue Int
l) BinaryOp
BOpMinus (IntValue Int
r)     = Int -> Value
IntValue (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
r)
evalBinaryOp (IntValue Int
l) BinaryOp
BOpMul (IntValue Int
r)       = Int -> Value
IntValue (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
r)

evalBinaryOp (Vec4Value V4 Float
l) BinaryOp
BOpMul (Mat4x4Value M44 Float
r)   = V4 Float -> Value
Vec4Value (M44 Float
r M44 Float -> V4 Float -> V4 Float
forall (m :: * -> *) (r :: * -> *) a.
(Functor m, Foldable r, Additive r, Num a) =>
m (r a) -> r a -> m a
!* V4 Float
l)
evalBinaryOp (Mat4x4Value M44 Float
l) BinaryOp
BOpMul (Mat4x4Value M44 Float
r) = M44 Float -> Value
Mat4x4Value (M44 Float
r M44 Float -> M44 Float -> M44 Float
forall (m :: * -> *) (t :: * -> *) (n :: * -> *) a.
(Functor m, Foldable t, Additive t, Additive n, Num a) =>
m (t a) -> t (n a) -> m (n a)
!*! M44 Float
l)

evalBinaryOp l :: Value
l@FloatValue{} BinaryOp
o (IntValue Int
r) = Value -> BinaryOp -> Value -> Value
evalBinaryOp Value
l BinaryOp
o (Float -> Value
FloatValue (Float -> Value) -> Float -> Value
forall a b. (a -> b) -> a -> b
$ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
r)
evalBinaryOp (IntValue Int
l) BinaryOp
o r :: Value
r@FloatValue{} = Value -> BinaryOp -> Value -> Value
evalBinaryOp (Float -> Value
FloatValue (Float -> Value) -> Float -> Value
forall a b. (a -> b) -> a -> b
$ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
l) BinaryOp
o Value
r

evalBinaryOp Value
l BinaryOp
o Value
r =
  String -> Value
forall a. HasCallStack => String -> a
error (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ String
"not implemented: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (Value, BinaryOp, Value) -> String
forall a. Show a => a -> String
show (Value
l, BinaryOp
o, Value
r)


evalUnaryOp :: UnaryOp -> Value -> Value
evalUnaryOp :: UnaryOp -> Value -> Value
evalUnaryOp UnaryOp
UOpMinus (FloatValue Float
v) = Float -> Value
FloatValue (-Float
v)
evalUnaryOp UnaryOp
UOpMinus (IntValue Int
v) = Int -> Value
IntValue (-Int
v)

evalUnaryOp UnaryOp
o Value
e =
  String -> Value
forall a. HasCallStack => String -> a
error (String -> Value) -> String -> Value
forall a b. (a -> b) -> a -> b
$ String
"not implemented: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (UnaryOp, Value) -> String
forall a. Show a => a -> String
show (UnaryOp
o, Value
e)