never executed always true always false
    1 {-|
    2 Module: Flaw.Graphics.Program.Internal
    3 Description: Internals for shader program support.
    4 License: MIT
    5 -}
    6 
    7 {-# LANGUAGE DeriveGeneric, GADTs, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, RankNTypes, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TypeFamilies, UndecidableInstances #-}
    8 
    9 module Flaw.Graphics.Program.Internal
   10   ( ScalarType(..)
   11   , Dimension(..)
   12   , ValueType(..)
   13   , valueTypeScalarsCount
   14   , OfScalarType(..)
   15   , OfVectorType
   16   , OfValueType(..)
   17   , OfAttributeType(..)
   18   , AttributeFormat(..)
   19   , AttributeType(..)
   20   , Normalization(..)
   21   , State(..)
   22   , Attribute(..)
   23   , Uniform(..)
   24   , Sampler(..)
   25   , SamplerDimension(..)
   26   , Target(..)
   27   , Stage(..)
   28   , Temp(..)
   29   , Node(..)
   30   , SamplerNode(..)
   31   , SampleNodeLod(..)
   32   , nodeValueType
   33   , nodeArrayValueType
   34   , Program
   35   , runProgram
   36   ) where
   37 
   38 import Control.Monad
   39 import Control.Monad.Reader
   40 import Data.Char
   41 import Data.Int
   42 import Data.Word
   43 import Data.IORef
   44 import qualified Data.Serialize as S
   45 import GHC.Generics(Generic)
   46 import Language.Haskell.TH
   47 
   48 import Flaw.Math
   49 import Flaw.Math.Internal
   50 
   51 -- | Supported scalar types in programs.
   52 data ScalarType
   53   = ScalarFloat
   54   | ScalarDouble
   55   | ScalarInt
   56   | ScalarUint
   57   | ScalarBool
   58   deriving (Eq, Ord, Show, Generic)
   59 instance S.Serialize ScalarType
   60 
   61 -- | Supported dimensions in programs.
   62 data Dimension
   63   = Dimension1
   64   | Dimension2
   65   | Dimension3
   66   | Dimension4
   67   deriving (Eq, Ord, Show, Generic)
   68 instance S.Serialize Dimension
   69 
   70 -- | Supported types in programs.
   71 data ValueType
   72   = ScalarValueType !ScalarType
   73   | VectorValueType !Dimension !ScalarType
   74   | MatrixValueType !Dimension !Dimension !ScalarType
   75   deriving (Eq, Ord, Show, Generic)
   76 instance S.Serialize ValueType
   77 
   78 -- | Number of scalars in type.
   79 valueTypeScalarsCount :: ValueType -> Int
   80 valueTypeScalarsCount vt = case vt of
   81   ScalarValueType _ -> 1
   82   VectorValueType d _ -> dim d
   83   MatrixValueType d1 d2 _ -> dim d1 * dim d2
   84   where
   85     dim d = case d of
   86       Dimension1 -> 1
   87       Dimension2 -> 2
   88       Dimension3 -> 3
   89       Dimension4 -> 4
   90 
   91 -- | Class of scalar types which can be used in program.
   92 class OfValueType a => OfScalarType a where
   93   -- | Get program scalar type.
   94   -- Argument is not used.
   95   scalarType :: a -> ScalarType
   96 
   97 instance OfScalarType Float where
   98   scalarType _ = ScalarFloat
   99 instance OfScalarType Double where
  100   scalarType _ = ScalarDouble
  101 instance OfScalarType Int32 where
  102   scalarType _ = ScalarInt
  103 instance OfScalarType Word32 where
  104   scalarType _ = ScalarUint
  105 instance OfScalarType Bool where
  106   scalarType _ = ScalarBool
  107 
  108 -- | Class of types which can be used in program.
  109 class Show a => OfValueType a where
  110   valueType :: a -> ValueType
  111   valueToShowList :: a -> [String]
  112   valueToShowList v = [show v]
  113 
  114 instance OfValueType Float where
  115   valueType _ = ScalarValueType ScalarFloat
  116 instance OfValueType Double where
  117   valueType _ = ScalarValueType ScalarDouble
  118 instance OfValueType Int32 where
  119   valueType _ = ScalarValueType ScalarInt
  120 instance OfValueType Word32 where
  121   valueType _ = ScalarValueType ScalarUint
  122 instance OfValueType Bool where
  123   valueType _ = ScalarValueType ScalarBool
  124 
  125 -- instance (OfScalarType a, Vectorized a) => OfValueType (Vec{1..4} a)
  126 fmap concat $ forM [1..maxVecDimension] $ \c -> do
  127   let name = mkName $ "Vec" ++ [intToDigit c]
  128   let t = conT name
  129   let d = conE $ mkName $ "Dimension" ++ [intToDigit c]
  130   ps <- forM [1..c] $ \p -> newName ['p', intToDigit p]
  131   [d|
  132     instance (OfScalarType a, Vectorized a) => OfValueType ($t a) where
  133       valueType _ = VectorValueType $d $ scalarType (undefined :: a)
  134       valueToShowList $(conP name $ map varP ps) = $(listE $ map (\p -> appE (varE 'show) $ varE p) ps)
  135     |]
  136 
  137 -- instance (OfScalarType a, Vectorized a) => OfValueType (Mat{1..4}x{1..4} a)
  138 fmap concat $ forM matDimensions $ \(ci, cj) -> do
  139   let name = mkName $ "Mat" ++ [intToDigit ci, 'x', intToDigit cj]
  140   let t = conT name
  141   let di = conE $ mkName $ "Dimension" ++ [intToDigit ci]
  142   let dj = conE $ mkName $ "Dimension" ++ [intToDigit cj]
  143   ps <- forM [(intToDigit i, intToDigit j) | i <- [1..ci], j <- [1..cj]] $ \(i, j) -> newName ['p', i, j]
  144   [d|
  145     instance (OfScalarType a, Vectorized a) => OfValueType ($t a) where
  146       valueType _ = MatrixValueType $di $dj $ scalarType (undefined :: a)
  147       valueToShowList $(conP name $ map varP ps) = $(listE $ map (\p -> appE (varE 'show) $ varE p) ps)
  148     |]
  149 
  150 -- | Class of vector types which can be used in program.
  151 class (OfValueType a, Vec a, OfScalarType (VecElement a)) => OfVectorType a
  152 
  153 instance (OfScalarType a, Vectorized a) => OfVectorType (Vec1 a)
  154 instance (OfScalarType a, Vectorized a) => OfVectorType (Vec2 a)
  155 instance (OfScalarType a, Vectorized a) => OfVectorType (Vec3 a)
  156 instance (OfScalarType a, Vectorized a) => OfVectorType (Vec4 a)
  157 
  158 -- | Class of types which can be used in vertex attribute.
  159 class OfValueType a => OfAttributeType a where
  160   -- | Typed attibute format.
  161   data AttributeFormat a :: *
  162   attributeFormatToType :: AttributeFormat a -> AttributeType
  163 
  164 -- | Attribute format ids.
  165 data AttributeType
  166   = ATFloat32
  167   | ATFloat16
  168   | ATInt32 !Normalization
  169   | ATInt16 !Normalization
  170   | ATInt8 !Normalization
  171   | ATUint32 !Normalization
  172   | ATUint16 !Normalization
  173   | ATUint8 !Normalization
  174   | ATVec1 !AttributeType
  175   | ATVec2 !AttributeType
  176   | ATVec3 !AttributeType
  177   | ATVec4 !AttributeType
  178   | ATMat1x1 !AttributeType
  179   | ATMat1x2 !AttributeType
  180   | ATMat1x3 !AttributeType
  181   | ATMat1x4 !AttributeType
  182   | ATMat2x1 !AttributeType
  183   | ATMat2x2 !AttributeType
  184   | ATMat2x3 !AttributeType
  185   | ATMat2x4 !AttributeType
  186   | ATMat3x1 !AttributeType
  187   | ATMat3x2 !AttributeType
  188   | ATMat3x3 !AttributeType
  189   | ATMat3x4 !AttributeType
  190   | ATMat4x1 !AttributeType
  191   | ATMat4x2 !AttributeType
  192   | ATMat4x3 !AttributeType
  193   | ATMat4x4 !AttributeType
  194   deriving (Eq, Ord, Show, Generic)
  195 instance S.Serialize AttributeType
  196 
  197 -- | Normalization mode.
  198 data Normalization
  199   = NonNormalized
  200   | Normalized
  201   deriving (Eq, Ord, Show, Generic)
  202 instance S.Serialize Normalization
  203 
  204 instance OfAttributeType Float where
  205   data AttributeFormat Float
  206     = AttributeFloat32
  207     | AttributeFloat16
  208     | AttributeFloatInt32 !Normalization
  209     | AttributeFloatInt16 !Normalization
  210     | AttributeFloatInt8 !Normalization
  211     | AttributeFloatUint32 !Normalization
  212     | AttributeFloatUint16 !Normalization
  213     | AttributeFloatUint8 !Normalization
  214   attributeFormatToType f = case f of
  215     AttributeFloat32 -> ATFloat32
  216     AttributeFloat16 -> ATFloat16
  217     AttributeFloatInt32 n -> ATInt32 n
  218     AttributeFloatInt16 n -> ATInt16 n
  219     AttributeFloatInt8 n -> ATInt8 n
  220     AttributeFloatUint32 n -> ATUint32 n
  221     AttributeFloatUint16 n -> ATUint16 n
  222     AttributeFloatUint8 n -> ATUint8 n
  223 
  224 instance OfAttributeType Int32 where
  225   data AttributeFormat Int32
  226     = AttributeInt32
  227     | AttributeInt16
  228     | AttributeInt8
  229   attributeFormatToType f = case f of
  230     AttributeInt32 -> ATInt32 NonNormalized
  231     AttributeInt16 -> ATInt16 NonNormalized
  232     AttributeInt8 -> ATInt8 NonNormalized
  233 
  234 instance OfAttributeType Word32 where
  235   data AttributeFormat Word32
  236     = AttributeUint32
  237     | AttributeUint16
  238     | AttributeUint8
  239   attributeFormatToType f = case f of
  240     AttributeUint32 -> ATUint32 NonNormalized
  241     AttributeUint16 -> ATUint16 NonNormalized
  242     AttributeUint8 -> ATUint8 NonNormalized
  243 
  244 -- instance (OfScalarType a, Vectorized a, OfAttributeType a) => OfAttributeType (Vec{1..4} a)
  245 forM ['1'..'4'] $ \c -> do
  246   let v = mkName $ "Vec" ++ [c]
  247   a <- newName "a"
  248   let conName = mkName $ "AttributeVec" ++ [c]
  249   b <- newName "b"
  250   instanceD (sequence [ [t| OfScalarType $(varT a) |], [t| Vectorized $(varT a) |], [t| OfAttributeType $(varT a) |] ]) (appT (conT ''OfAttributeType) $ appT (conT v) $ varT a)
  251     [ newtypeInstD (return []) ''AttributeFormat [appT (conT v) $ varT a] Nothing (normalC conName [return (Bang NoSourceUnpackedness NoSourceStrictness, AppT (ConT ''AttributeFormat) $ VarT a)]) []
  252     , funD 'attributeFormatToType [clause [conP conName [varP b]] (normalB [| $(conE $ mkName $ "ATVec" ++ [c]) (attributeFormatToType $(varE b)) |]) []]
  253     ]
  254 
  255 -- instance (OfScalarType a, Vectorized a, OfAttributeType a) => OfAttributeType (Mat{1..4}x{1..4} a)
  256 forM matDimensions $ \(ci, cj) -> do
  257   let v = mkName $ "Mat" ++ [intToDigit ci, 'x', intToDigit cj]
  258   a <- newName "a"
  259   let conName = mkName $ "AttributeMat" ++ [intToDigit ci, 'x', intToDigit cj]
  260   b <- newName "b"
  261   instanceD (sequence [ [t| OfScalarType $(varT a) |], [t| Vectorized $(varT a) |], [t| OfAttributeType $(varT a) |] ]) (appT (conT ''OfAttributeType) $ appT (conT v) $ varT a)
  262     [ newtypeInstD (return []) ''AttributeFormat [appT (conT v) $ varT a] Nothing (normalC conName [return (Bang NoSourceUnpackedness NoSourceStrictness, AppT (ConT ''AttributeFormat) $ VarT a)]) []
  263     , funD 'attributeFormatToType [clause [conP conName [varP b]] (normalB [| $(conE $ mkName $ "ATMat" ++ [intToDigit ci, 'x', intToDigit cj]) (attributeFormatToType $(varE b)) |]) []]
  264     ]
  265 
  266 -- | State of the program while constructing.
  267 data State = State
  268   { stateStage :: !Stage
  269   , stateTemps :: [Temp]
  270   , stateTempsCount :: {-# UNPACK #-} !Int
  271   , stateTargets :: [Target]
  272   } deriving Show
  273 
  274 data Attribute = Attribute
  275   { attributeSlot :: {-# UNPACK #-} !Int
  276   , attributeOffset :: {-# UNPACK #-} !Int
  277   , attributeDivisor :: {-# UNPACK #-} !Int
  278   , attributeType :: !AttributeType
  279   , attributeValueType :: !ValueType
  280   } deriving (Eq, Ord, Show, Generic)
  281 instance S.Serialize Attribute
  282 
  283 data Uniform = Uniform
  284   { uniformSlot :: {-# UNPACK #-} !Int
  285   , uniformOffset :: {-# UNPACK #-} !Int
  286   , uniformSize :: {-# UNPACK #-} !Int
  287   , uniformType :: !ValueType
  288   } deriving (Eq, Ord, Show, Generic)
  289 instance S.Serialize Uniform
  290 
  291 data Sampler = Sampler
  292   { samplerSlot :: {-# UNPACK #-} !Int
  293   , samplerDimension :: !SamplerDimension
  294   , samplerSampleType :: !ValueType
  295   , samplerCoordsType :: !ValueType
  296   } deriving (Eq, Ord, Show, Generic)
  297 instance S.Serialize Sampler
  298 
  299 data SamplerDimension
  300   = Sampler1D
  301   | Sampler2D
  302   | Sampler3D
  303   | SamplerCube
  304   deriving (Eq, Ord, Show, Generic)
  305 instance S.Serialize SamplerDimension
  306 
  307 data Target
  308   = PositionTarget (Node Float4)
  309   | ColorTarget !Int (Node Float4)
  310   | DualColorTarget (Node Float4) (Node Float4)
  311   | DepthTarget (Node Float)
  312   deriving Show
  313 
  314 data Stage
  315   = VertexStage
  316   | PixelStage
  317   | EndStage
  318   deriving (Eq, Ord, Show)
  319 
  320 data Temp = forall a. OfValueType a => Temp
  321   { tempIndex :: {-# UNPACK #-} !Int
  322   , tempNode :: !(Node a)
  323   , tempStage :: !Stage
  324   , tempType :: !ValueType
  325   }
  326 deriving instance Show Temp
  327 
  328 data Node a where
  329   AttributeNode :: Attribute -> Node a
  330   UniformNode :: Uniform -> Node a
  331   TempNode :: Int -> Node a
  332   ConstNode :: OfValueType a => ValueType -> a -> Node a
  333   IndexNode :: (OfValueType a, OfValueType b, Integral b) => ValueType -> ValueType -> Node [a] -> Node b -> Node a
  334   AddNode :: (OfValueType a, Num a) => ValueType -> Node a -> Node a -> Node a
  335   SubtractNode :: (OfValueType a, Num a) => ValueType -> Node a -> Node a -> Node a
  336   MultiplyNode :: (OfValueType a, Num a) => ValueType -> Node a -> Node a -> Node a
  337   DivideNode :: (OfValueType a, Fractional a) => ValueType -> Node a -> Node a -> Node a
  338   RecipNode :: (OfValueType a, Fractional a) => ValueType -> Node a -> Node a
  339   NegateNode :: (OfValueType a, Num a) => ValueType -> Node a -> Node a
  340   AbsNode :: (OfValueType a, Num a) => ValueType -> Node a -> Node a
  341   SignumNode :: (OfValueType a, Num a) => ValueType -> Node a -> Node a
  342   MinNode :: OfValueType a => ValueType -> Node a -> Node a -> Node a
  343   MaxNode :: OfValueType a => ValueType -> Node a -> Node a -> Node a
  344   ClampNode :: OfValueType a => ValueType -> Node a -> Node a -> Node a -> Node a
  345   LerpNode :: OfValueType a => ValueType -> Node a -> Node a -> Node a -> Node a
  346   EqualNode :: OfValueType a => ValueType -> Node a -> Node a -> Node Bool
  347   LessNode :: OfValueType a => ValueType -> Node a -> Node a -> Node Bool
  348   LessEqualNode :: OfValueType a => ValueType -> Node a -> Node a -> Node Bool
  349   IfNode :: OfValueType a => ValueType -> Node Bool -> Node a -> Node a -> Node a
  350   PiNode :: (OfValueType a, Floating a) => ValueType -> Node a
  351   ExpNode :: (OfValueType a, Floating a) => ValueType -> Node a -> Node a
  352   SqrtNode :: (OfValueType a, Floating a) => ValueType -> Node a -> Node a
  353   InvSqrtNode :: (OfValueType a, Floating a) => ValueType -> Node a -> Node a
  354   LogNode :: (OfValueType a, Floating a) => ValueType -> Node a -> Node a
  355   PowNode :: (OfValueType a, Floating a) => ValueType -> Node a -> Node a -> Node a
  356   LogBaseNode :: (OfValueType a, Floating a) => ValueType -> Node a -> Node a -> Node a
  357   SinNode :: (OfValueType a, Floating a) => ValueType -> Node a -> Node a
  358   TanNode :: (OfValueType a, Floating a) => ValueType -> Node a -> Node a
  359   CosNode :: (OfValueType a, Floating a) => ValueType -> Node a -> Node a
  360   AsinNode :: (OfValueType a, Floating a) => ValueType -> Node a -> Node a
  361   AtanNode :: (OfValueType a, Floating a) => ValueType -> Node a -> Node a
  362   AcosNode :: (OfValueType a, Floating a) => ValueType -> Node a -> Node a
  363   SinhNode :: (OfValueType a, Floating a) => ValueType -> Node a -> Node a
  364   TanhNode :: (OfValueType a, Floating a) => ValueType -> Node a -> Node a
  365   CoshNode :: (OfValueType a, Floating a) => ValueType -> Node a -> Node a
  366   AsinhNode :: (OfValueType a, Floating a) => ValueType -> Node a -> Node a
  367   AtanhNode :: (OfValueType a, Floating a) => ValueType -> Node a -> Node a
  368   AcoshNode :: (OfValueType a, Floating a) => ValueType -> Node a -> Node a
  369   MulNode :: (OfValueType a, OfValueType b, Mul a b, OfValueType (MulResult a b)) => ValueType -> ValueType -> ValueType -> Node a -> Node b -> Node (MulResult a b)
  370   DotNode :: (OfVectorType v, OfScalarType (VecElement v), Dot v) => ValueType -> ValueType -> Node v -> Node v -> Node (VecElement v)
  371   CrossNode :: (OfVectorType v, Cross v) => ValueType -> Node v -> Node v -> Node v
  372   NormNode :: (OfVectorType v, OfScalarType (VecElement v), Norm v) => ValueType -> ValueType -> Node v -> Node (VecElement v)
  373   Norm2Node :: (OfVectorType v, OfScalarType (VecElement v), Norm v) => ValueType -> ValueType -> Node v -> Node (VecElement v)
  374   NormalizeNode :: (OfVectorType v, Normalize v) => ValueType -> Node v -> Node v
  375   DdxNode :: OfValueType a => ValueType -> Node a -> Node a
  376   DdyNode :: OfValueType a => ValueType -> Node a -> Node a
  377   FloorNode :: OfValueType a => ValueType -> Node a -> Node a
  378   InstanceIdNode :: Node Word32
  379   ComponentNode :: OfVectorType v => ValueType -> ValueType -> Char -> Node v -> Node (VecElement v)
  380   SwizzleNode :: (OfVectorType a, OfVectorType b) => ValueType -> ValueType -> String -> Node a -> Node b
  381   SampleNode :: (OfVectorType (v c), OfVectorType (v Int32)) =>
  382     { sampleNodeSamplerNode :: SamplerNode s (v c)
  383     , sampleNodeCoordsNode :: Node (v c)
  384     , sampleNodeOffsetNode :: Maybe (Node (v Int32))
  385     , sampleNodeLod :: SampleNodeLod v c
  386     } -> Node s
  387   CastNode :: (OfValueType a, OfValueType b) => ValueType -> ValueType -> Node a -> Node b
  388   Combine2VecNode :: (OfValueType a, OfValueType b, OfValueType r)
  389     => ValueType -> ValueType -> ValueType -> Node a -> Node b -> Node r
  390   Combine3VecNode :: (OfValueType a, OfValueType b, OfValueType c, OfValueType r)
  391     => ValueType -> ValueType -> ValueType -> ValueType -> Node a -> Node b -> Node c -> Node r
  392   Combine4VecNode :: (OfValueType a, OfValueType b, OfValueType c, OfValueType d, OfValueType r)
  393     => ValueType -> ValueType -> ValueType -> ValueType -> ValueType -> Node a -> Node b -> Node c -> Node d -> Node r
  394   ScreenToTextureNode :: OfValueType a => ValueType -> Node a -> Node a
  395   NormalizeSampledDepthNode :: Node Float -> Node Float
  396   FragCoordNode :: Node Float4
  397 
  398 deriving instance Show (Node a)
  399 
  400 newtype SamplerNode s c = SamplerNode Sampler deriving Show
  401 
  402 data SampleNodeLod v a
  403   = SampleNodeAutoLod
  404   | SampleNodeLod (Node a)
  405   | SampleNodeBiasLod (Node a)
  406   | SampleNodeGradLod (Node (v a)) (Node (v a))
  407   deriving Show
  408 
  409 nodeValueType :: OfValueType a => Node a -> ValueType
  410 nodeValueType node = valueType $ (undefined :: (Node a -> a)) node
  411 
  412 nodeArrayValueType :: OfValueType a => Node [a] -> ValueType
  413 nodeArrayValueType node = valueType $ (undefined :: (Node [a] -> a)) node
  414 
  415 instance OfVectorType v => Vec (Node v) where
  416   type VecElement (Node v) = Node (VecElement v)
  417   vecLength _ = vecLength (undefined :: v)
  418   vecToList _ = undefined
  419   vecFromScalar e = CastNode (nodeValueType e) (valueType (undefined :: v)) e
  420 
  421 instance (OfValueType a, Num a) => Num (Node a) where
  422   (+) = AddNode $ valueType (undefined :: a)
  423   (*) = MultiplyNode $ valueType (undefined :: a)
  424   (-) = SubtractNode $ valueType (undefined :: a)
  425   negate = NegateNode $ valueType (undefined :: a)
  426   abs = AbsNode $ valueType (undefined :: a)
  427   signum = SignumNode $ valueType (undefined :: a)
  428   fromInteger = (ConstNode $ valueType (undefined :: a)) . fromInteger
  429 
  430 instance (OfValueType a, Fractional a) => Fractional (Node a) where
  431   (/) = DivideNode $ valueType (undefined :: a)
  432   recip = RecipNode $ valueType (undefined :: a)
  433   fromRational = (ConstNode $ valueType (undefined :: a)) . fromRational
  434 
  435 instance (OfValueType a, Floating a) => Floating (Node a) where
  436   pi = PiNode $ valueType (undefined :: a)
  437   exp = ExpNode $ valueType (undefined :: a)
  438   sqrt = SqrtNode $ valueType (undefined :: a)
  439   log = LogNode $ valueType (undefined :: a)
  440   (**) = PowNode $ valueType (undefined :: a)
  441   logBase = LogBaseNode $ valueType (undefined :: a)
  442   sin = SinNode $ valueType (undefined :: a)
  443   tan = TanNode $ valueType (undefined :: a)
  444   cos = CosNode $ valueType (undefined :: a)
  445   asin = AsinNode $ valueType (undefined :: a)
  446   atan = AtanNode $ valueType (undefined :: a)
  447   acos = AcosNode $ valueType (undefined :: a)
  448   sinh = SinhNode $ valueType (undefined :: a)
  449   tanh = TanhNode $ valueType (undefined :: a)
  450   cosh = CoshNode $ valueType (undefined :: a)
  451   asinh = AsinhNode $ valueType (undefined :: a)
  452   atanh = AtanhNode $ valueType (undefined :: a)
  453   acosh = AcoshNode $ valueType (undefined :: a)
  454 
  455 instance (OfValueType a, OfValueType b, OfValueType (MulResult a b), Mul a b) => Mul (Node a) (Node b) where
  456   type MulResult (Node a) (Node b) = Node (MulResult a b)
  457   mul = MulNode (valueType (undefined :: a)) (valueType (undefined :: b)) (valueType (undefined :: MulResult a b))
  458 
  459 instance (OfVectorType v, Dot v) => Dot (Node v) where
  460   dot = DotNode (valueType (undefined :: v)) (valueType (undefined :: VecElement v))
  461 
  462 instance (OfVectorType v, Cross v) => Cross (Node v) where
  463   cross = CrossNode (valueType (undefined :: v))
  464 
  465 instance (OfVectorType v, Norm v) => Norm (Node v) where
  466   norm = NormNode (valueType (undefined :: v)) (valueType (undefined :: VecElement v))
  467   norm2 = Norm2Node (valueType (undefined :: v)) (valueType (undefined :: VecElement v))
  468 
  469 instance (OfVectorType v, Normalize v) => Normalize (Node v) where
  470   normalize = NormalizeNode (valueType (undefined :: v))
  471 
  472 {- instance
  473   ( OfVectorType v
  474   , OfScalarType (VecElement v)
  475   , Vec{X..W} v
  476   ) => Vec{X..W} (Node v)
  477 -}
  478 forM "xyzw" $ \c -> do
  479   v <- newName "v"
  480   let vc = mkName $ "Vec" ++ [toUpper c]
  481   instanceD (sequence
  482     [ [t| OfVectorType $(varT v) |]
  483     , [t| $(conT vc) $(varT v) |]
  484     ]) [t| $(conT vc) (Node $(varT v)) |]
  485     [ funD (mkName $ [c, '_']) [clause [] (normalB [| ComponentNode (valueType (undefined :: $(varT v))) (valueType (undefined :: VecElement $(varT v))) $(litE $ charL c) |]) []]
  486     ]
  487 
  488 {- instance
  489   ( OfVectorType v
  490   , OfVectorType (SwizzleVec{X..W}{1..4}Result v)
  491   , SwizzleVec{X..W}{1..4} v
  492   ) => SwizzleVec{X..W}{1..4} (Node v)
  493 -}
  494 forM [(maxComp, dim) | maxComp <- [1..4], dim <- [1..4]] $ \(maxComp, dim) -> do
  495   v <- newName "v"
  496   let
  497     components = take maxComp "xyzw"
  498     nameSuffix = [toUpper $ last components, intToDigit dim]
  499     sv = mkName $ "SwizzleVec" ++ nameSuffix
  500     resultTypeName = mkName $ "SwizzleVecResult" ++ nameSuffix
  501     variants = filter variantFilter $ genVariants dim where
  502       genVariants 0 = [""]
  503       genVariants len = [c : cs | c <- components, cs <- genVariants $ len - 1]
  504       variantFilter variant = all (\c -> elem c components) variant && elem (last components) variant
  505     funDecl variant = do
  506       funD (mkName $ variant ++ "__") [clause [] (normalB [| SwizzleNode (valueType (undefined :: $(varT v))) (valueType (undefined :: $(conT resultTypeName) $(varT v))) $(litE $ stringL variant) |]) []]
  507     resultTypeDecl = tySynInstD resultTypeName $ tySynEqn
  508       [ [t| Node $(varT v) |] ]
  509       [t| Node ($(conT resultTypeName) $(varT v)) |]
  510   instanceD (sequence
  511     [ [t| OfVectorType $(varT v) |]
  512     , [t| OfVectorType ($(conT $ mkName $ "SwizzleVecResult" ++ nameSuffix) $(varT v)) |]
  513     , [t| $(conT sv) $(varT v) |]
  514     ])
  515     [t| $(conT sv) (Node $(varT v)) |] $ resultTypeDecl : map funDecl variants
  516 
  517 -- | Program monad.
  518 type Program a = ReaderT (IORef State) IO a
  519 
  520 runProgram :: Program () -> IO State
  521 runProgram program = do
  522   stateVar <- newIORef State
  523     { stateTemps = []
  524     , stateTempsCount = 0
  525     , stateStage = VertexStage
  526     , stateTargets = []
  527     }
  528   runReaderT program stateVar
  529   state@State
  530     { stateStage = stage
  531     } <- readIORef stateVar
  532   if stage /= EndStage then fail "wrong program: stage should be end"
  533   else return ()
  534   return state