{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE StrictData                 #-}
{-# LANGUAGE ViewPatterns               #-}
module Language.GLSL.Runtime.Eval where

import           Control.Lens                     ((^.))
import           Control.Monad                    (foldM, foldM_)
import           Control.Monad.Trans.State.Strict (evalStateT, get, modify')
import qualified Data.IntMap                      as M
import qualified Data.Text.Lazy                   as LT
import qualified Data.Text.Lazy.IO                as IO
import qualified Debug.Trace                      as Trace
import           Language.GLSL.AST
import           Language.GLSL.Decls              (addDecl, addDeclN, addDeclNE,
                                                   emptyDecls, getDeclNE,
                                                   toUniformId)
import           Language.GLSL.Parser             (parseShader)
import           Language.GLSL.PrettyPrint        (pp, ppExpr, ppGlobalDecl,
                                                   ppNameExpr, ppSwizzle,
                                                   ppVecIndex)
import qualified Language.GLSL.Runtime.PrimFuns   as PrimFuns
import           Language.GLSL.Runtime.Value      (Eval, EvalResult (..),
                                                   EvalState (..), Proc (..),
                                                   Value (..), defaultValue,
                                                   evalBinaryOp, evalCoerce,
                                                   evalUnaryOp, isNaNValue,
                                                   roundValue)
import           Linear                           (R1 (..), R2 (..), R3 (..),
                                                   R4 (..))


traceAssignments :: Bool
traceAssignments :: Bool
traceAssignments = Bool
False

trace :: String -> a -> a
trace :: String -> a -> a
trace = if Bool
traceAssignments then String -> a -> a
forall a. String -> a -> a
Trace.trace else (a -> a) -> String -> a -> a
forall a b. a -> b -> a
const a -> a
forall a. a -> a
id


eval :: LT.Text -> Either String Value
eval :: Text -> Either String Value
eval Text
code = do
  GLSL ()
glsl <- Text -> Either String (GLSL ())
forall a. Annot a => Text -> Either String (GLSL a)
parseShader Text
code
  EvalResult Value -> Either String Value
forall a. EvalResult a -> Either String a
fromResult (EvalResult Value -> Either String Value)
-> EvalResult Value -> Either String Value
forall a b. (a -> b) -> a -> b
$ StateT EvalState EvalResult Value -> EvalState -> EvalResult Value
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (GLSL () -> StateT EvalState EvalResult Value
evalGLSL GLSL ()
glsl) EvalState
startState


startState :: EvalState
startState :: EvalState
startState = EvalState :: IntMap Proc
-> Maybe Proc -> Decls Value -> Maybe Value -> EvalState
EvalState
  { stProcs :: IntMap Proc
stProcs = IntMap Proc
forall a. IntMap a
M.empty
  , stMainProc :: Maybe Proc
stMainProc = Maybe Proc
forall a. Maybe a
Nothing

  , globals :: Decls Value
globals = Decls Value
forall a. Decls a
emptyDecls
  , gl_Position :: Maybe Value
gl_Position = Maybe Value
forall a. Maybe a
Nothing
  }


evalGLSL :: GLSL () -> Eval Value
evalGLSL :: GLSL () -> StateT EvalState EvalResult Value
evalGLSL (GLSL Version
_ [TopDecl ()]
d) = do
  (TopDecl () -> StateT EvalState EvalResult ())
-> [TopDecl ()] -> StateT EvalState EvalResult ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TopDecl () -> StateT EvalState EvalResult ()
discoverTopDecl [TopDecl ()]
d
  StateT EvalState EvalResult ()
evalMain
  -- maybe (FloatValue 0) id . gl_Position <$> get
  Value -> Value
roundValue (Value -> Value)
-> StateT EvalState EvalResult Value
-> StateT EvalState EvalResult Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocalState -> NameExpr -> StateT EvalState EvalResult Value
getValue LocalState
emptyLocals (Name -> NameExpr
NameExpr (Namespace -> NameId -> Name
Name Namespace
NsOut (Int -> NameId
NameId Int
0)))

discoverTopDecl :: TopDecl () -> Eval ()
discoverTopDecl :: TopDecl () -> StateT EvalState EvalResult ()
discoverTopDecl (LayoutDecl LayoutSpec
_ GlobalDecl
d) = GlobalDecl -> StateT EvalState EvalResult ()
discoverGlobalDecl GlobalDecl
d
discoverTopDecl (GlobalDecl GlobalDecl
d) = GlobalDecl -> StateT EvalState EvalResult ()
discoverGlobalDecl GlobalDecl
d
discoverTopDecl (ProcDecl ProcName
ProcMain [ParamDecl]
params [StmtAnnot ()]
body) =
  (EvalState -> EvalState) -> StateT EvalState EvalResult ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((EvalState -> EvalState) -> StateT EvalState EvalResult ())
-> (EvalState -> EvalState) -> StateT EvalState EvalResult ()
forall a b. (a -> b) -> a -> b
$ \EvalState
st -> EvalState
st{stMainProc :: Maybe Proc
stMainProc = Proc -> Maybe Proc
forall a. a -> Maybe a
Just (Proc -> Maybe Proc) -> Proc -> Maybe Proc
forall a b. (a -> b) -> a -> b
$ [ParamDecl] -> [StmtAnnot ()] -> Proc
Proc [ParamDecl]
params [StmtAnnot ()]
body}
discoverTopDecl (ProcDecl (ProcName (NameId Int
n)) [ParamDecl]
params [StmtAnnot ()]
body) =
  (EvalState -> EvalState) -> StateT EvalState EvalResult ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((EvalState -> EvalState) -> StateT EvalState EvalResult ())
-> (EvalState -> EvalState) -> StateT EvalState EvalResult ()
forall a b. (a -> b) -> a -> b
$ \st :: EvalState
st@EvalState{Maybe Value
Maybe Proc
IntMap Proc
Decls Value
gl_Position :: Maybe Value
globals :: Decls Value
stMainProc :: Maybe Proc
stProcs :: IntMap Proc
gl_Position :: EvalState -> Maybe Value
globals :: EvalState -> Decls Value
stMainProc :: EvalState -> Maybe Proc
stProcs :: EvalState -> IntMap Proc
..} -> EvalState
st{stProcs :: IntMap Proc
stProcs = Int -> Proc -> IntMap Proc -> IntMap Proc
forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
n ([ParamDecl] -> [StmtAnnot ()] -> Proc
Proc [ParamDecl]
params [StmtAnnot ()]
body) IntMap Proc
stProcs}

discoverGlobalDecl :: GlobalDecl -> Eval ()
discoverGlobalDecl :: GlobalDecl -> StateT EvalState EvalResult ()
discoverGlobalDecl (GDecl GDeclKind
GkUniform (TyStruct NameId
_ [(Type, NameId)]
fields) (Name Namespace
NsU NameId
n)) =
  (EvalState -> EvalState) -> StateT EvalState EvalResult ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((EvalState -> EvalState) -> StateT EvalState EvalResult ())
-> (EvalState -> EvalState) -> StateT EvalState EvalResult ()
forall a b. (a -> b) -> a -> b
$ \st :: EvalState
st@EvalState{Maybe Value
Maybe Proc
IntMap Proc
Decls Value
gl_Position :: Maybe Value
globals :: Decls Value
stMainProc :: Maybe Proc
stProcs :: IntMap Proc
gl_Position :: EvalState -> Maybe Value
globals :: EvalState -> Decls Value
stMainProc :: EvalState -> Maybe Proc
stProcs :: EvalState -> IntMap Proc
..} ->
    EvalState
st{globals :: Decls Value
globals = ((Type, NameId) -> Decls Value -> Decls Value)
-> Decls Value -> [(Type, NameId)] -> Decls Value
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Type
ty, NameId
m) -> Namespace -> NameId -> Value -> Decls Value -> Decls Value
forall a. Namespace -> NameId -> a -> Decls a -> Decls a
addDecl Namespace
NsU ((NameId, NameId) -> NameId
toUniformId (NameId
n, NameId
m)) (Type -> Value
defaultValue Type
ty)) Decls Value
globals [(Type, NameId)]
fields}
discoverGlobalDecl (GDecl GDeclKind
GkOut Type
ty Name
n) =
  (EvalState -> EvalState) -> StateT EvalState EvalResult ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((EvalState -> EvalState) -> StateT EvalState EvalResult ())
-> (EvalState -> EvalState) -> StateT EvalState EvalResult ()
forall a b. (a -> b) -> a -> b
$ \st :: EvalState
st@EvalState{Maybe Value
Maybe Proc
IntMap Proc
Decls Value
gl_Position :: Maybe Value
globals :: Decls Value
stMainProc :: Maybe Proc
stProcs :: IntMap Proc
gl_Position :: EvalState -> Maybe Value
globals :: EvalState -> Decls Value
stMainProc :: EvalState -> Maybe Proc
stProcs :: EvalState -> IntMap Proc
..} -> EvalState
st{globals :: Decls Value
globals = Name -> Value -> Decls Value -> Decls Value
forall a. Name -> a -> Decls a -> Decls a
addDeclN Name
n (Type -> Value
defaultValue Type
ty) Decls Value
globals}
discoverGlobalDecl (GDecl GDeclKind
GkIn Type
ty Name
n) =
  (EvalState -> EvalState) -> StateT EvalState EvalResult ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((EvalState -> EvalState) -> StateT EvalState EvalResult ())
-> (EvalState -> EvalState) -> StateT EvalState EvalResult ()
forall a b. (a -> b) -> a -> b
$ \st :: EvalState
st@EvalState{Maybe Value
Maybe Proc
IntMap Proc
Decls Value
gl_Position :: Maybe Value
globals :: Decls Value
stMainProc :: Maybe Proc
stProcs :: IntMap Proc
gl_Position :: EvalState -> Maybe Value
globals :: EvalState -> Decls Value
stMainProc :: EvalState -> Maybe Proc
stProcs :: EvalState -> IntMap Proc
..} -> EvalState
st{globals :: Decls Value
globals = Name -> Value -> Decls Value -> Decls Value
forall a. Name -> a -> Decls a -> Decls a
addDeclN Name
n (Type -> Value
defaultValue Type
ty) Decls Value
globals}
discoverGlobalDecl d :: GlobalDecl
d@(GDecl GDeclKind
GkUniform Type
_ Name
_) =
  String -> StateT EvalState EvalResult ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT EvalState EvalResult ())
-> String -> StateT EvalState EvalResult ()
forall a b. (a -> b) -> a -> b
$ String
"unsupported uniform type in decl: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (GlobalDecl -> Builder) -> GlobalDecl -> String
forall a. (a -> Builder) -> a -> String
pp GlobalDecl -> Builder
ppGlobalDecl GlobalDecl
d


evalMain :: Eval ()
evalMain :: StateT EvalState EvalResult ()
evalMain = do
  Just Proc
mainProc <- EvalState -> Maybe Proc
stMainProc (EvalState -> Maybe Proc)
-> StateT EvalState EvalResult EvalState
-> StateT EvalState EvalResult (Maybe Proc)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT EvalState EvalResult EvalState
forall (m :: * -> *) s. Monad m => StateT s m s
get
  Proc -> [Value] -> StateT EvalState EvalResult ()
evalProc Proc
mainProc []
  () -> StateT EvalState EvalResult ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

newtype LocalState = LocalState
  { LocalState -> IntMap Value
temps :: M.IntMap Value
  }

emptyLocals :: LocalState
emptyLocals :: LocalState
emptyLocals = LocalState :: IntMap Value -> LocalState
LocalState
  { temps :: IntMap Value
temps = IntMap Value
forall a. IntMap a
M.empty
  }

evalProc :: Proc -> [Value] -> Eval ()
evalProc :: Proc -> [Value] -> StateT EvalState EvalResult ()
evalProc (Proc [ParamDecl]
_params [StmtAnnot ()]
ss) [Value]
_args =
  (LocalState
 -> StmtAnnot () -> StateT EvalState EvalResult LocalState)
-> LocalState -> [StmtAnnot ()] -> StateT EvalState EvalResult ()
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m ()
foldM_ LocalState
-> StmtAnnot () -> StateT EvalState EvalResult LocalState
evalStmtAnnot LocalState
emptyLocals [StmtAnnot ()]
ss

evalStmtAnnot :: LocalState -> StmtAnnot () -> Eval LocalState
evalStmtAnnot :: LocalState
-> StmtAnnot () -> StateT EvalState EvalResult LocalState
evalStmtAnnot LocalState
lst (SA () Stmt ()
s) = LocalState -> Stmt () -> StateT EvalState EvalResult LocalState
evalStmt LocalState
lst Stmt ()
s

evalStmt :: LocalState -> Stmt () -> Eval LocalState
evalStmt :: LocalState -> Stmt () -> StateT EvalState EvalResult LocalState
evalStmt LocalState
lst (AssignStmt Name
n Expr
e) = do
  Value
v <- LocalState -> Expr -> StateT EvalState EvalResult Value
evalExpr LocalState
lst Expr
e
  LocalState
-> NameExpr -> Value -> StateT EvalState EvalResult LocalState
setValue LocalState
lst (Name -> NameExpr
NameExpr Name
n) Value
v
evalStmt LocalState
lst (DeclStmt LocalDecl
d) = LocalState -> LocalDecl -> StateT EvalState EvalResult LocalState
evalLocalDecl LocalState
lst LocalDecl
d
evalStmt LocalState
lst (EmitStmt Emit
e) = LocalState -> Emit -> StateT EvalState EvalResult LocalState
evalEmit LocalState
lst Emit
e
evalStmt LocalState
lst (IfStmt NameId
cond [StmtAnnot ()]
thens [StmtAnnot ()]
elses) = do
  BoolValue Bool
v <- LocalState -> NameExpr -> StateT EvalState EvalResult Value
getValue LocalState
lst (Name -> NameExpr
NameExpr (Namespace -> NameId -> Name
Name Namespace
NsT NameId
cond))
  if Bool
v
    then (LocalState
 -> StmtAnnot () -> StateT EvalState EvalResult LocalState)
-> LocalState
-> [StmtAnnot ()]
-> StateT EvalState EvalResult LocalState
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM LocalState
-> StmtAnnot () -> StateT EvalState EvalResult LocalState
evalStmtAnnot LocalState
lst [StmtAnnot ()]
thens
    else (LocalState
 -> StmtAnnot () -> StateT EvalState EvalResult LocalState)
-> LocalState
-> [StmtAnnot ()]
-> StateT EvalState EvalResult LocalState
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM LocalState
-> StmtAnnot () -> StateT EvalState EvalResult LocalState
evalStmtAnnot LocalState
lst [StmtAnnot ()]
elses

evalEmit :: LocalState -> Emit -> Eval LocalState
evalEmit :: LocalState -> Emit -> StateT EvalState EvalResult LocalState
evalEmit LocalState
lst Emit
EmitFragDepth = LocalState -> StateT EvalState EvalResult LocalState
forall (m :: * -> *) a. Monad m => a -> m a
return LocalState
lst
evalEmit LocalState
lst (EmitPosition Expr
e) = do
  Value
v <- LocalState -> Expr -> StateT EvalState EvalResult Value
evalExpr LocalState
lst Expr
e
  (EvalState -> EvalState) -> StateT EvalState EvalResult ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((EvalState -> EvalState) -> StateT EvalState EvalResult ())
-> (EvalState -> EvalState) -> StateT EvalState EvalResult ()
forall a b. (a -> b) -> a -> b
$ \EvalState
st -> EvalState
st{gl_Position :: Maybe Value
gl_Position = Value -> Maybe Value
forall a. a -> Maybe a
Just Value
v}
  LocalState -> StateT EvalState EvalResult LocalState
forall (m :: * -> *) a. Monad m => a -> m a
return LocalState
lst

evalLocalDecl :: LocalState -> LocalDecl -> Eval LocalState
evalLocalDecl :: LocalState -> LocalDecl -> StateT EvalState EvalResult LocalState
evalLocalDecl LocalState
lst (LDecl Type
ty (Name -> NameExpr
NameExpr (Name -> NameExpr) -> (NameId -> Name) -> NameId -> NameExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Namespace -> NameId -> Name
Name Namespace
NsT -> NameExpr
n) Maybe Expr
Nothing) =
  let v :: Value
v = Type -> Value
defaultValue Type
ty in
  LocalState
-> NameExpr -> Value -> StateT EvalState EvalResult LocalState
setValue LocalState
lst NameExpr
n Value
v
evalLocalDecl LocalState
lst (LDecl Type
ty (Name -> NameExpr
NameExpr (Name -> NameExpr) -> (NameId -> Name) -> NameId -> NameExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Namespace -> NameId -> Name
Name Namespace
NsT -> NameExpr
n) (Just Expr
e)) = do
  Value
v <- LocalState -> Expr -> StateT EvalState EvalResult Value
evalExpr LocalState
lst Expr
e StateT EvalState EvalResult Value
-> (Value -> StateT EvalState EvalResult Value)
-> StateT EvalState EvalResult Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Type -> Value -> StateT EvalState EvalResult Value
evalCoerce Type
ty
  LocalState
-> NameExpr -> Value -> StateT EvalState EvalResult LocalState
setValue LocalState
lst NameExpr
n Value
v

evalExpr :: LocalState -> Expr -> Eval Value
evalExpr :: LocalState -> Expr -> StateT EvalState EvalResult Value
evalExpr LocalState
lst = \case
  BinaryExpr ExprAtom
l BinaryOp
op ExprAtom
r -> do
    Value
lv <- LocalState -> ExprAtom -> StateT EvalState EvalResult Value
evalExprAtom LocalState
lst ExprAtom
l
    Value
rv <- LocalState -> ExprAtom -> StateT EvalState EvalResult Value
evalExprAtom LocalState
lst ExprAtom
r
    Value -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> StateT EvalState EvalResult Value)
-> Value -> StateT EvalState EvalResult Value
forall a b. (a -> b) -> a -> b
$ Value -> BinaryOp -> Value -> Value
evalBinaryOp Value
lv BinaryOp
op Value
rv
  UnaryExpr UnaryOp
op ExprAtom
e -> do
    Value
v <- LocalState -> ExprAtom -> StateT EvalState EvalResult Value
evalExprAtom LocalState
lst ExprAtom
e
    Value -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> StateT EvalState EvalResult Value)
-> Value -> StateT EvalState EvalResult Value
forall a b. (a -> b) -> a -> b
$ UnaryOp -> Value -> Value
evalUnaryOp UnaryOp
op Value
v
  AtomExpr ExprAtom
e -> LocalState -> ExprAtom -> StateT EvalState EvalResult Value
evalExprAtom LocalState
lst ExprAtom
e
  FunCallExpr FunName
fun [ExprAtom]
args -> do
    [Value]
vals <- (ExprAtom -> StateT EvalState EvalResult Value)
-> [ExprAtom] -> StateT EvalState EvalResult [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (LocalState -> ExprAtom -> StateT EvalState EvalResult Value
evalExprAtom LocalState
lst) [ExprAtom]
args
    FunName -> [Value] -> StateT EvalState EvalResult Value
PrimFuns.eval FunName
fun [Value]
vals
  e :: Expr
e@TextureExpr{} ->
    String -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT EvalState EvalResult Value)
-> String -> StateT EvalState EvalResult Value
forall a b. (a -> b) -> a -> b
$ String
"texture() not implemented: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Expr -> Builder) -> Expr -> String
forall a. (a -> Builder) -> a -> String
pp Expr -> Builder
ppExpr Expr
e

evalExprAtom :: LocalState -> ExprAtom -> Eval Value
evalExprAtom :: LocalState -> ExprAtom -> StateT EvalState EvalResult Value
evalExprAtom LocalState
lst = \case
  LitFloatExpr Cast
_ Float
f   -> Value -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> StateT EvalState EvalResult Value)
-> Value -> StateT EvalState EvalResult Value
forall a b. (a -> b) -> a -> b
$ Float -> Value
FloatValue Float
f
  LitIntExpr Cast
_ Int
i     -> Value -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> StateT EvalState EvalResult Value)
-> Value -> StateT EvalState EvalResult Value
forall a b. (a -> b) -> a -> b
$ Int -> Value
IntValue Int
i
  IdentifierExpr NameExpr
n   -> LocalState -> NameExpr -> StateT EvalState EvalResult Value
getValue LocalState
lst NameExpr
n
  SwizzleExpr NameId
n Swizzle
s    -> LocalState -> NameExpr -> StateT EvalState EvalResult Value
getValue LocalState
lst (Name -> NameExpr
NameExpr (Namespace -> NameId -> Name
Name Namespace
NsT NameId
n)) StateT EvalState EvalResult Value
-> (Value -> StateT EvalState EvalResult Value)
-> StateT EvalState EvalResult Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Swizzle -> Value -> StateT EvalState EvalResult Value
evalVecIndex Swizzle
s
  VecIndexExpr NameExpr
n Swizzle
i   -> LocalState -> NameExpr -> StateT EvalState EvalResult Value
getValue LocalState
lst NameExpr
n StateT EvalState EvalResult Value
-> (Value -> StateT EvalState EvalResult Value)
-> StateT EvalState EvalResult Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Swizzle -> Value -> StateT EvalState EvalResult Value
evalVecIndex Swizzle
i
  MatIndexExpr NameExpr
n Swizzle
i Swizzle
j -> LocalState -> NameExpr -> StateT EvalState EvalResult Value
getValue LocalState
lst NameExpr
n StateT EvalState EvalResult Value
-> (Value -> StateT EvalState EvalResult Value)
-> StateT EvalState EvalResult Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Swizzle -> Swizzle -> Value -> StateT EvalState EvalResult Value
evalMatIndex Swizzle
i Swizzle
j

evalVecIndex :: Swizzle -> Value -> Eval Value
evalVecIndex :: Swizzle -> Value -> StateT EvalState EvalResult Value
evalVecIndex Swizzle
X (Vec2Value V2 Float
v) = Value -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> StateT EvalState EvalResult Value)
-> Value -> StateT EvalState EvalResult Value
forall a b. (a -> b) -> a -> b
$ Float -> Value
FloatValue (Float -> Value) -> Float -> Value
forall a b. (a -> b) -> a -> b
$ V2 Float
v V2 Float -> Getting Float (V2 Float) Float -> Float
forall s a. s -> Getting a s a -> a
^. Getting Float (V2 Float) Float
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x
evalVecIndex Swizzle
Y (Vec2Value V2 Float
v) = Value -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> StateT EvalState EvalResult Value)
-> Value -> StateT EvalState EvalResult Value
forall a b. (a -> b) -> a -> b
$ Float -> Value
FloatValue (Float -> Value) -> Float -> Value
forall a b. (a -> b) -> a -> b
$ V2 Float
v V2 Float -> Getting Float (V2 Float) Float -> Float
forall s a. s -> Getting a s a -> a
^. Getting Float (V2 Float) Float
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y
evalVecIndex Swizzle
X (Vec3Value V3 Float
v) = Value -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> StateT EvalState EvalResult Value)
-> Value -> StateT EvalState EvalResult Value
forall a b. (a -> b) -> a -> b
$ Float -> Value
FloatValue (Float -> Value) -> Float -> Value
forall a b. (a -> b) -> a -> b
$ V3 Float
v V3 Float -> Getting Float (V3 Float) Float -> Float
forall s a. s -> Getting a s a -> a
^. Getting Float (V3 Float) Float
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x
evalVecIndex Swizzle
Y (Vec3Value V3 Float
v) = Value -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> StateT EvalState EvalResult Value)
-> Value -> StateT EvalState EvalResult Value
forall a b. (a -> b) -> a -> b
$ Float -> Value
FloatValue (Float -> Value) -> Float -> Value
forall a b. (a -> b) -> a -> b
$ V3 Float
v V3 Float -> Getting Float (V3 Float) Float -> Float
forall s a. s -> Getting a s a -> a
^. Getting Float (V3 Float) Float
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y
evalVecIndex Swizzle
Z (Vec3Value V3 Float
v) = Value -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> StateT EvalState EvalResult Value)
-> Value -> StateT EvalState EvalResult Value
forall a b. (a -> b) -> a -> b
$ Float -> Value
FloatValue (Float -> Value) -> Float -> Value
forall a b. (a -> b) -> a -> b
$ V3 Float
v V3 Float -> Getting Float (V3 Float) Float -> Float
forall s a. s -> Getting a s a -> a
^. Getting Float (V3 Float) Float
forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z
evalVecIndex Swizzle
X (Vec4Value V4 Float
v) = Value -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> StateT EvalState EvalResult Value)
-> Value -> StateT EvalState EvalResult Value
forall a b. (a -> b) -> a -> b
$ Float -> Value
FloatValue (Float -> Value) -> Float -> Value
forall a b. (a -> b) -> a -> b
$ V4 Float
v V4 Float -> Getting Float (V4 Float) Float -> Float
forall s a. s -> Getting a s a -> a
^. Getting Float (V4 Float) Float
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x
evalVecIndex Swizzle
Y (Vec4Value V4 Float
v) = Value -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> StateT EvalState EvalResult Value)
-> Value -> StateT EvalState EvalResult Value
forall a b. (a -> b) -> a -> b
$ Float -> Value
FloatValue (Float -> Value) -> Float -> Value
forall a b. (a -> b) -> a -> b
$ V4 Float
v V4 Float -> Getting Float (V4 Float) Float -> Float
forall s a. s -> Getting a s a -> a
^. Getting Float (V4 Float) Float
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y
evalVecIndex Swizzle
Z (Vec4Value V4 Float
v) = Value -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> StateT EvalState EvalResult Value)
-> Value -> StateT EvalState EvalResult Value
forall a b. (a -> b) -> a -> b
$ Float -> Value
FloatValue (Float -> Value) -> Float -> Value
forall a b. (a -> b) -> a -> b
$ V4 Float
v V4 Float -> Getting Float (V4 Float) Float -> Float
forall s a. s -> Getting a s a -> a
^. Getting Float (V4 Float) Float
forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z
evalVecIndex Swizzle
W (Vec4Value V4 Float
v) = Value -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> StateT EvalState EvalResult Value)
-> Value -> StateT EvalState EvalResult Value
forall a b. (a -> b) -> a -> b
$ Float -> Value
FloatValue (Float -> Value) -> Float -> Value
forall a b. (a -> b) -> a -> b
$ V4 Float
v V4 Float -> Getting Float (V4 Float) Float -> Float
forall s a. s -> Getting a s a -> a
^. Getting Float (V4 Float) Float
forall (t :: * -> *) a. R4 t => Lens' (t a) a
_w
evalVecIndex Swizzle
s Value
v = String -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT EvalState EvalResult Value)
-> String -> StateT EvalState EvalResult Value
forall a b. (a -> b) -> a -> b
$ String
"cannot access " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Swizzle -> Builder) -> Swizzle -> String
forall a. (a -> Builder) -> a -> String
pp Swizzle -> Builder
ppSwizzle Swizzle
s String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" on " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
v

evalMatIndex :: Swizzle -> Swizzle -> Value -> Eval Value
evalMatIndex :: Swizzle -> Swizzle -> Value -> StateT EvalState EvalResult Value
evalMatIndex Swizzle
i Swizzle
j (Mat4x4Value M44 Float
v) =
  Value -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> StateT EvalState EvalResult Value)
-> Value -> StateT EvalState EvalResult Value
forall a b. (a -> b) -> a -> b
$ Float -> Value
FloatValue (Float -> Value) -> Float -> Value
forall a b. (a -> b) -> a -> b
$ M44 Float
v M44 Float -> Getting Float (M44 Float) Float -> Float
forall s a. s -> Getting a s a -> a
^. (Swizzle
-> (V4 Float -> Const Float (V4 Float))
-> M44 Float
-> Const Float (M44 Float)
forall (t :: * -> *) (f :: * -> *) a.
(Functor f, R4 t) =>
Swizzle -> (a -> f a) -> t a -> f (t a)
swizzle Swizzle
i ((V4 Float -> Const Float (V4 Float))
 -> M44 Float -> Const Float (M44 Float))
-> Getting Float (V4 Float) Float
-> Getting Float (M44 Float) Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Swizzle -> Getting Float (V4 Float) Float
forall (t :: * -> *) (f :: * -> *) a.
(Functor f, R4 t) =>
Swizzle -> (a -> f a) -> t a -> f (t a)
swizzle Swizzle
j)
  where
    swizzle :: Swizzle -> (a -> f a) -> t a -> f (t a)
swizzle Swizzle
X = (a -> f a) -> t a -> f (t a)
forall (t :: * -> *) a. R1 t => Lens' (t a) a
_x
    swizzle Swizzle
Y = (a -> f a) -> t a -> f (t a)
forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y
    swizzle Swizzle
Z = (a -> f a) -> t a -> f (t a)
forall (t :: * -> *) a. R3 t => Lens' (t a) a
_z
    swizzle Swizzle
W = (a -> f a) -> t a -> f (t a)
forall (t :: * -> *) a. R4 t => Lens' (t a) a
_w
evalMatIndex Swizzle
i Swizzle
j Value
v =
  String -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT EvalState EvalResult Value)
-> String -> StateT EvalState EvalResult Value
forall a b. (a -> b) -> a -> b
$ String
"cannot access [" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Swizzle -> Builder) -> Swizzle -> String
forall a. (a -> Builder) -> a -> String
pp Swizzle -> Builder
ppVecIndex Swizzle
i String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"][" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (Swizzle -> Builder) -> Swizzle -> String
forall a. (a -> Builder) -> a -> String
pp Swizzle -> Builder
ppVecIndex Swizzle
j String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"]"
      String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" on " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
v


setValue :: LocalState -> NameExpr -> Value -> Eval LocalState
setValue :: LocalState
-> NameExpr -> Value -> StateT EvalState EvalResult LocalState
setValue lst :: LocalState
lst@LocalState{IntMap Value
temps :: IntMap Value
temps :: LocalState -> IntMap Value
..} n :: NameExpr
n@(NameExpr (Name Namespace
NsT (NameId Int
nId))) Value
v =
  String
-> StateT EvalState EvalResult LocalState
-> StateT EvalState EvalResult LocalState
forall a. String -> a -> a
trace ((NameExpr -> Builder) -> NameExpr -> String
forall a. (a -> Builder) -> a -> String
pp NameExpr -> Builder
ppNameExpr NameExpr
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
v) (StateT EvalState EvalResult LocalState
 -> StateT EvalState EvalResult LocalState)
-> StateT EvalState EvalResult LocalState
-> StateT EvalState EvalResult LocalState
forall a b. (a -> b) -> a -> b
$
  if Value -> Bool
isNaNValue Value
v
    then String -> StateT EvalState EvalResult LocalState
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT EvalState EvalResult LocalState)
-> String -> StateT EvalState EvalResult LocalState
forall a b. (a -> b) -> a -> b
$ (NameExpr -> Builder) -> NameExpr -> String
forall a. (a -> Builder) -> a -> String
pp NameExpr -> Builder
ppNameExpr NameExpr
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
v
    else LocalState -> StateT EvalState EvalResult LocalState
forall (m :: * -> *) a. Monad m => a -> m a
return LocalState
lst{temps :: IntMap Value
temps = Int -> Value -> IntMap Value -> IntMap Value
forall a. Int -> a -> IntMap a -> IntMap a
M.insert Int
nId Value
v IntMap Value
temps}
setValue LocalState
lst NameExpr
n Value
v = do
  (EvalState -> EvalState) -> StateT EvalState EvalResult ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
modify' ((EvalState -> EvalState) -> StateT EvalState EvalResult ())
-> (EvalState -> EvalState) -> StateT EvalState EvalResult ()
forall a b. (a -> b) -> a -> b
$ \st :: EvalState
st@EvalState{Maybe Value
Maybe Proc
IntMap Proc
Decls Value
gl_Position :: Maybe Value
globals :: Decls Value
stMainProc :: Maybe Proc
stProcs :: IntMap Proc
gl_Position :: EvalState -> Maybe Value
globals :: EvalState -> Decls Value
stMainProc :: EvalState -> Maybe Proc
stProcs :: EvalState -> IntMap Proc
..} -> EvalState
st{globals :: Decls Value
globals = NameExpr -> Value -> Decls Value -> Decls Value
forall a. NameExpr -> a -> Decls a -> Decls a
addDeclNE NameExpr
n Value
v Decls Value
globals}
  String
-> StateT EvalState EvalResult LocalState
-> StateT EvalState EvalResult LocalState
forall a. String -> a -> a
trace ((NameExpr -> Builder) -> NameExpr -> String
forall a. (a -> Builder) -> a -> String
pp NameExpr -> Builder
ppNameExpr NameExpr
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
v) (StateT EvalState EvalResult LocalState
 -> StateT EvalState EvalResult LocalState)
-> StateT EvalState EvalResult LocalState
-> StateT EvalState EvalResult LocalState
forall a b. (a -> b) -> a -> b
$
    if Value -> Bool
isNaNValue Value
v
      then String -> StateT EvalState EvalResult LocalState
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT EvalState EvalResult LocalState)
-> String -> StateT EvalState EvalResult LocalState
forall a b. (a -> b) -> a -> b
$ (NameExpr -> Builder) -> NameExpr -> String
forall a. (a -> Builder) -> a -> String
pp NameExpr -> Builder
ppNameExpr NameExpr
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" = " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
v
      else LocalState -> StateT EvalState EvalResult LocalState
forall (m :: * -> *) a. Monad m => a -> m a
return LocalState
lst


getValue :: LocalState -> NameExpr -> Eval Value
getValue :: LocalState -> NameExpr -> StateT EvalState EvalResult Value
getValue LocalState{IntMap Value
temps :: IntMap Value
temps :: LocalState -> IntMap Value
..} (NameExpr (Name Namespace
NsT (NameId Int
n))) = do
  let Just Value
v = Int -> IntMap Value -> Maybe Value
forall a. Int -> IntMap a -> Maybe a
M.lookup Int
n IntMap Value
temps
  Value -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v
getValue LocalState
_ NameExpr
n = do
  Maybe Value
v <- NameExpr -> Decls Value -> Maybe Value
forall a. NameExpr -> Decls a -> Maybe a
getDeclNE NameExpr
n (Decls Value -> Maybe Value)
-> (EvalState -> Decls Value) -> EvalState -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EvalState -> Decls Value
globals (EvalState -> Maybe Value)
-> StateT EvalState EvalResult EvalState
-> StateT EvalState EvalResult (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT EvalState EvalResult EvalState
forall (m :: * -> *) s. Monad m => StateT s m s
get
  case Maybe Value
v of
    Maybe Value
Nothing -> String -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> StateT EvalState EvalResult Value)
-> String -> StateT EvalState EvalResult Value
forall a b. (a -> b) -> a -> b
$ String
"undefined global: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (NameExpr -> Builder) -> NameExpr -> String
forall a. (a -> Builder) -> a -> String
pp NameExpr -> Builder
ppNameExpr NameExpr
n
    Just Value
ok -> Value -> StateT EvalState EvalResult Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
ok


main :: IO ()
main :: IO ()
main = do
  Text
txt <- String -> IO Text
IO.readFile String
"../large-shaders/xax.vert"
  Either String Value -> IO ()
forall a. Show a => a -> IO ()
print (Either String Value -> IO ()) -> Either String Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Either String Value
eval Text
txt