lambdacube-edsl (empty) → 0.2.0
raw patch · 11 files changed
+3080/−0 lines, 11 filesdep +basedep +bytestringdep +bytestring-triesetup-changed
Dependencies added: base, bytestring, bytestring-trie, containers, ghc-prim, lambdacube-core, mtl, vector
Files
- LICENSE +28/−0
- Setup.hs +2/−0
- lambdacube-edsl.cabal +71/−0
- src/lib/LambdaCube/Convert/PrimFun.hs +167/−0
- src/lib/LambdaCube/Convert/ToDeBruijn.hs +272/−0
- src/lib/LambdaCube/Language.hs +508/−0
- src/lib/LambdaCube/Language/HOAS.hs +270/−0
- src/lib/LambdaCube/Language/PrimFun.hs +172/−0
- src/lib/LambdaCube/Language/ReifyType.hs +640/−0
- src/lib/LambdaCube/Language/Sampler.hs +263/−0
- src/lib/LambdaCube/Language/Type.hs +687/−0
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2009-2012, Csaba Hruska+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.++3. Neither the name of the author nor the names of its contributors may be+ used to endorse or promote products derived from this software without+ specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ lambdacube-edsl.cabal view
@@ -0,0 +1,71 @@+Name: lambdacube-edsl+Version: 0.2.0+Cabal-Version: >= 1.10+Build-Type: Simple+License: BSD3+License-File: LICENSE+Author: Csaba Hruska, Gergely Patai+Maintainer: csaba (dot) hruska (at) gmail (dot) com+Stability: experimental+Homepage: http://lambdacube3d.wordpress.com/+Bug-Reports: https://github.com/csabahruska/lc-dsl/issues+Category: Graphics+Tested-With: GHC == 7.6.3+Synopsis: LambdaCube 3D EDSL definition++Library+ Build-Depends:+ base >=4.6 && <5,+ containers >=0.5 && <0.6,+ mtl >=2.2 && <2.3,+ bytestring >=0.10 && <0.11,+ bytestring-trie >=0.2 && <0.3,+ vector >=0.10 && <0.11,+ ghc-prim,+ --data-reify >= 0.6 && <0.7,+ lambdacube-core == 0.2.0++ default-language: Haskell2010+ hs-source-dirs: src/lib+ Exposed-modules:+ LambdaCube.Convert.PrimFun+ LambdaCube.Convert.ToDeBruijn+ --LambdaCube.Convert.ToDeBruijnRec+ LambdaCube.Language+ LambdaCube.Language.HOAS+ LambdaCube.Language.PrimFun+ LambdaCube.Language.ReifyType+ LambdaCube.Language.Sampler+ LambdaCube.Language.Type+ + GHC-options:+-- -Werror+ -Wall+ -fno-warn-missing-signatures+ -fno-warn-name-shadowing+ -fno-warn-orphans+ -fno-warn-unused-binds+ -fno-warn-unused-do-bind+ -fspec-constr-count=10+ -funbox-strict-fields+ -O0+-- for profiling+-- -auto-all+-- -caf-all++ default-extensions:+ ConstraintKinds+ DataKinds+ DeriveDataTypeable+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ GADTs+ KindSignatures+ MultiParamTypeClasses+ ScopedTypeVariables+ StandaloneDeriving+ TypeFamilies+ TypeOperators+ TypeSynonymInstances+ PolyKinds
+ src/lib/LambdaCube/Convert/PrimFun.hs view
@@ -0,0 +1,167 @@+module LambdaCube.Convert.PrimFun where++import qualified LambdaCube.Language.PrimFun as T+import LambdaCube.Core.PrimFun++convertPrimFun :: T.PrimFun a b -> PrimFun+convertPrimFun a = case a of+ -- Vec/Mat (de)construction+ T.PrimTupToV2 -> PrimTupToV2+ T.PrimTupToV3 -> PrimTupToV3+ T.PrimTupToV4 -> PrimTupToV4+ T.PrimV2ToTup -> PrimV2ToTup+ T.PrimV3ToTup -> PrimV3ToTup+ T.PrimV4ToTup -> PrimV4ToTup++ -- Arithmetic Functions (componentwise)+ T.PrimAdd -> PrimAdd + T.PrimAddS -> PrimAddS+ T.PrimSub -> PrimSub + T.PrimSubS -> PrimSubS + T.PrimMul -> PrimMul + T.PrimMulS -> PrimMulS+ T.PrimDiv -> PrimDiv + T.PrimDivS -> PrimDivS+ T.PrimNeg -> PrimNeg + T.PrimMod -> PrimMod + T.PrimModS -> PrimModS++ -- Bit-wise Functions+ T.PrimBAnd -> PrimBAnd + T.PrimBAndS -> PrimBAndS + T.PrimBOr -> PrimBOr + T.PrimBOrS -> PrimBOrS + T.PrimBXor -> PrimBXor + T.PrimBXorS -> PrimBXorS + T.PrimBNot -> PrimBNot + T.PrimBShiftL -> PrimBShiftL + T.PrimBShiftLS -> PrimBShiftLS+ T.PrimBShiftR -> PrimBShiftR + T.PrimBShiftRS -> PrimBShiftRS++ -- Logic Functions+ T.PrimAnd -> PrimAnd+ T.PrimOr -> PrimOr + T.PrimXor -> PrimXor+ T.PrimNot -> PrimNot+ T.PrimAny -> PrimAny+ T.PrimAll -> PrimAll++ -- Angle and Trigonometry Functions+ T.PrimACos -> PrimACos + T.PrimACosH -> PrimACosH + T.PrimASin -> PrimASin + T.PrimASinH -> PrimASinH + T.PrimATan -> PrimATan + T.PrimATan2 -> PrimATan2 + T.PrimATanH -> PrimATanH + T.PrimCos -> PrimCos + T.PrimCosH -> PrimCosH + T.PrimDegrees -> PrimDegrees+ T.PrimRadians -> PrimRadians+ T.PrimSin -> PrimSin + T.PrimSinH -> PrimSinH + T.PrimTan -> PrimTan + T.PrimTanH -> PrimTanH ++ -- Exponential Functions+ T.PrimPow -> PrimPow + T.PrimExp -> PrimExp + T.PrimLog -> PrimLog + T.PrimExp2 -> PrimExp2 + T.PrimLog2 -> PrimLog2 + T.PrimSqrt -> PrimSqrt + T.PrimInvSqrt -> PrimInvSqrt++ -- Common Functions+ T.PrimIsNan -> PrimIsNan + T.PrimIsInf -> PrimIsInf + T.PrimAbs -> PrimAbs + T.PrimSign -> PrimSign + T.PrimFloor -> PrimFloor + T.PrimTrunc -> PrimTrunc + T.PrimRound -> PrimRound + T.PrimRoundEven -> PrimRoundEven + T.PrimCeil -> PrimCeil + T.PrimFract -> PrimFract + T.PrimModF -> PrimModF + T.PrimMin -> PrimMin + T.PrimMinS -> PrimMinS + T.PrimMax -> PrimMax + T.PrimMaxS -> PrimMaxS + T.PrimClamp -> PrimClamp + T.PrimClampS -> PrimClampS + T.PrimMix -> PrimMix + T.PrimMixS -> PrimMixS + T.PrimMixB -> PrimMixB + T.PrimStep -> PrimStep + T.PrimStepS -> PrimStepS + T.PrimSmoothStep -> PrimSmoothStep + T.PrimSmoothStepS -> PrimSmoothStepS++ -- Integer/Float Conversion Functions+ T.PrimFloatBitsToInt -> PrimFloatBitsToInt + T.PrimFloatBitsToUInt -> PrimFloatBitsToUInt + T.PrimIntBitsToFloat -> PrimIntBitsToFloat + T.PrimUIntBitsToFloat -> PrimUIntBitsToFloat ++ -- Geometric Functions+ T.PrimLength -> PrimLength + T.PrimDistance -> PrimDistance + T.PrimDot -> PrimDot + T.PrimCross -> PrimCross + T.PrimNormalize -> PrimNormalize + T.PrimFaceForward -> PrimFaceForward+ T.PrimReflect -> PrimReflect + T.PrimRefract -> PrimRefract ++ -- Matrix Functions+ T.PrimTranspose -> PrimTranspose + T.PrimDeterminant -> PrimDeterminant + T.PrimInverse -> PrimInverse + T.PrimOuterProduct -> PrimOuterProduct+ T.PrimMulMatVec -> PrimMulMatVec + T.PrimMulVecMat -> PrimMulVecMat + T.PrimMulMatMat -> PrimMulMatMat ++ -- Vector and Scalar Relational Functions+ T.PrimLessThan -> PrimLessThan + T.PrimLessThanEqual -> PrimLessThanEqual + T.PrimGreaterThan -> PrimGreaterThan + T.PrimGreaterThanEqual -> PrimGreaterThanEqual+ T.PrimEqualV -> PrimEqualV + T.PrimEqual -> PrimEqual + T.PrimNotEqualV -> PrimNotEqualV + T.PrimNotEqual -> PrimNotEqual ++ -- Fragment Processing Functions+ T.PrimDFdx -> PrimDFdx + T.PrimDFdy -> PrimDFdy + T.PrimFWidth -> PrimFWidth++ -- Noise Functions+ T.PrimNoise1 -> PrimNoise1+ T.PrimNoise2 -> PrimNoise2+ T.PrimNoise3 -> PrimNoise3+ T.PrimNoise4 -> PrimNoise4++ -- Texture Lookup Functions+ T.PrimTextureSize -> PrimTextureSize+ T.PrimTexture -> PrimTexture+ T.PrimTextureB -> PrimTexture+ T.PrimTextureProj -> PrimTextureProj+ T.PrimTextureProjB -> PrimTextureProj+ T.PrimTextureLod -> PrimTextureLod+ T.PrimTextureOffset -> PrimTextureOffset+ T.PrimTextureOffsetB -> PrimTextureOffset+ T.PrimTexelFetch -> PrimTexelFetch+ T.PrimTexelFetchOffset -> PrimTexelFetchOffset+ T.PrimTextureProjOffset -> PrimTextureProjOffset+ T.PrimTextureProjOffsetB -> PrimTextureProjOffset+ T.PrimTextureLodOffset -> PrimTextureLodOffset+ T.PrimTextureProjLod -> PrimTextureProjLod+ T.PrimTextureProjLodOffset -> PrimTextureProjLodOffset+ T.PrimTextureGrad -> PrimTextureGrad+ T.PrimTextureGradOffset -> PrimTextureGradOffset+ T.PrimTextureProjGrad -> PrimTextureProjGrad+ T.PrimTextureProjGradOffset -> PrimTextureProjGradOffset
+ src/lib/LambdaCube/Convert/ToDeBruijn.hs view
@@ -0,0 +1,272 @@+module LambdaCube.Convert.ToDeBruijn (convertGPOutput) where++import GHC.TypeLits++import Debug.Trace++import LambdaCube.Language.Type (FlatTuple(..),Frequency(..))+import LambdaCube.Language.ReifyType (GPU,Tuple(..),TupleIdx(..))+import qualified LambdaCube.Language.Type as T+import qualified LambdaCube.Language.ReifyType as T hiding (Shadow)+import qualified LambdaCube.Language.PrimFun as T+import qualified LambdaCube.Language.HOAS as H+import LambdaCube.Core.DeBruijn+import LambdaCube.Core.Type+import LambdaCube.Convert.PrimFun+import LambdaCube.Core.Type as G++toInt :: KnownNat n => T.NatNum n -> Int+toInt (a :: T.NatNum n) = fromInteger $ natVal a++prjIdx i lyt = i--length lyt - i - 1+++prjToInt :: TupleIdx t e -> Int+prjToInt ZeroTupIdx = 0+prjToInt (SuccTupIdx i) = 1 + prjToInt i++genTupLen :: GPU a => Int -> a -> Int+genTupLen i a = sum $ map tySize $ take i rt+ where+ rt = reverse t+ Tuple t = genTy a++type Layout = [[Ty]]++genTy :: GPU a => a -> Ty+genTy = T.tupleType++convertGPOutput :: H.GPOutput o -> N+convertGPOutput (H.SamplerOut a b) = samplerOut a $ convertExp [] b+convertGPOutput (H.ScreenOut a) = screenOut $ convertGP a+convertGPOutput (H.MultiOut a) = multiOut $ map convertGPOutput a++-- GP+convertGP :: H.Exp T.Obj t -> N+convertGP = convertOpenGP []++convertOpenGP :: Layout -> H.Exp T.Obj t -> N+convertOpenGP = cvt+ where+ cvt :: Layout -> H.Exp T.Obj t -> N+ cvt lyt (H.Fetch n p i) = fetch n (convertFetchPrimitive p) (T.toInputList i)+ cvt lyt (H.Transform vs ps) = transform (convertFun1Vert lyt vs) (cvt lyt ps)+ cvt lyt (H.Reassemble sh ps) = reassemble (convertGeometryShader lyt sh) (cvt lyt ps)+ cvt lyt (H.Rasterize ctx ps) = rasterize (convertRasterContext ctx) $ cvt lyt ps+ cvt lyt (H.FrameBuffer fb) = frameBuffer (convertFrameBuffer fb)+ cvt lyt (H.Accumulate ctx f sh fs fb) = accumulate (convertAccumulationContext lyt ctx) (convertFragmentFilter lyt f)+ (convertFun1Frag lyt sh)+ (cvt lyt fs)+ (cvt lyt fb)+ cvt lyt (H.PrjFrameBuffer n idx fb) = prjFrameBuffer n (prjToInt idx) $ convertGP fb+ cvt lyt (H.PrjImage n idx img) = prjImage n (toInt idx) $ convertGP img++-- Vertex+convertOpenVertexOut :: Layout -- environment+ -> H.VertexOut clipDistances t -- expression to be converted+ -> N+convertOpenVertexOut lyt = cvt+ where+ cvt :: H.VertexOut clipDistances t' -> N+ cvt (H.VertexOut e1 e2 e3 ie :: H.VertexOut clipDistances t') = vertexOut (convertOpenExp lyt e1) (convertOpenExp lyt e2) (convertOpenFlatExp lyt e3) (convertOpenInterpolatedFlatExp lyt ie)++-- Fragment+convertOpenFragmentOut :: forall t.+ Layout -- environment+ -> H.FragmentOut t -- expression to be converted+ -> N+convertOpenFragmentOut lyt = cvt+ where+ cvt :: H.FragmentOut t' -> N+ cvt (H.FragmentOut fe :: H.FragmentOut t') = fragmentOut $ convertOpenFlatExp lyt fe+ cvt (H.FragmentOutDepth e fe :: H.FragmentOut t') = fragmentOutDepth (convertOpenExp lyt e) (convertOpenFlatExp lyt fe)+ cvt (H.FragmentOutRastDepth fe :: H.FragmentOut t') = fragmentOutRastDepth $ convertOpenFlatExp lyt fe++convertFragmentFilter :: (GPU a)+ => Layout+ -> H.FragmentFilter a+ -> N+convertFragmentFilter = cvt+ where+ cvt :: (GPU a) => Layout -> H.FragmentFilter a -> N+ cvt lyt H.PassAll = passAll+ cvt lyt (H.Filter f) = filter_ $ convertFun1Exp lyt f++-- Geometry+convertOpenGeometryOut :: forall i clipDistances t.+ Layout -- environment+ -> H.GeometryOut i clipDistances t -- expression to be converted+ -> N+convertOpenGeometryOut lyt = cvt+ where+ cvt :: H.GeometryOut i clipDistances t' -> N+ cvt (H.GeometryOut e1 e2 e3 e4 ie :: H.GeometryOut i clipDistances t') = geometryOut (convertOpenExp lyt e1)+ (convertOpenExp lyt e2)+ (convertOpenExp lyt e3)+ (convertOpenFlatExp lyt e4)+ (convertOpenInterpolatedFlatExp lyt ie)++convertGeometryShader :: Layout+ -> H.GeometryShader inputPrimitive outputPrimitive inputClipDistances outputClipDistances layerCount a b+ -> N+convertGeometryShader = cvt+ where+ cvt :: Layout -> H.GeometryShader inputPrimitive outputPrimitive inputClipDistances outputClipDistances layerCount a b -> N+ cvt lyt (H.GeometryShader a b c e1 e2 e3) = geometryShader (toInt a) (convertOutputPrimitive b) c (convertFun1Exp lyt e1)+ (convertFun1Exp lyt e2)+ (convertFun1Geom lyt e3)++-- Common+convertOpenInterpolatedFlatExp :: forall stage t.+ Layout -- environment+ -> H.InterpolatedFlatExp stage t -- expression to be converted+ -> [N]+convertOpenInterpolatedFlatExp lyt = cvt+ where+ cvt :: H.InterpolatedFlatExp stage t' -> [N]+ cvt (ZT) = []+ cvt (e:.xs) = cvt' e : cvt xs++ cvt' :: T.Interpolated (H.Exp stage) t' -> N+ cvt' (T.Flat e) = flat $ convertOpenExp lyt e+ cvt' (T.Smooth e) = smooth $ convertOpenExp lyt e+ cvt' (T.NoPerspective e) = noPerspective $ convertOpenExp lyt e++convertOpenFlatExp :: forall stage t.+ Layout -- environment+ -> H.FlatExp stage t -- expression to be converted+ -> [N]+convertOpenFlatExp lyt = cvt+ where+ cvt :: H.FlatExp stage t' -> [N]+ cvt (ZT) = []+ cvt (e:.xs) = convertOpenExp lyt e : cvt xs++convertOpenExp :: forall stage t.+ Layout -- environment+ -> H.Exp stage t -- expression to be converted+ -> N+convertOpenExp lyt = cvt+ where+ cvt :: forall stage t' . H.Exp stage t' -> N+ cvt (H.Tag i li :: H.Exp stage t') = var (genTy (undefined :: t')) (prjIdx i lyt) li+ cvt (H.Const v :: H.Exp stage t') = const_ (genTy (undefined :: t')) (T.toValue v)+ cvt (H.PrimVar v :: H.Exp stage t') = primVar (genTy (undefined :: t')) (fst $ T.toInput v)+ cvt (H.Uni v :: H.Exp stage t') = uni (genTy (undefined :: t')) (fst $ T.toInput v)+ cvt (H.Tup tupl :: H.Exp stage t') = tup (genTy (undefined :: t')) $ convertTuple lyt tupl+ cvt (H.Prj idx (e :: H.Exp stage e') :: H.Exp stage' t') = prj (genTy (undefined :: t')) (genTupLen (prjToInt idx) (undefined :: e')) $ cvt e+ cvt (H.Cond e1 e2 e3 :: H.Exp stage t') = cond (genTy (undefined :: t')) (cvt e1) (cvt e2) (cvt e3)+ cvt (H.PrimApp p e :: H.Exp stage t') = primApp (genTy (undefined :: t')) (convertPrimFun p) $ cvt e+ cvt (H.Sampler f em t :: H.Exp stage t') = sampler (genTy (undefined :: t')) f em $ cvt t+ cvt (H.TextureSlot n t :: H.Exp stage t') = textureSlot n (convertTextureType t)+ cvt (H.Texture t s m d :: H.Exp stage t') = texture (convertTextureType t) (T.toValue s) (convertMipMap m) (map convertGP d)+ cvt (H.Loop e1 e2 e3 s :: H.Exp stage t') = loop (genTy (undefined :: t')) (convertFun1Exp lyt e1) (convertFun1Exp lyt e2) (convertFun1Exp lyt e3) (cvt s)+ cvt (H.Let v fn) = let_ (convertOpenExp lyt v) (convertOpenExp lyt . fn . H.Shr)+ cvt (H.Shr e) = e++convertFun1Vert :: forall a b clipDistances. GPU a+ => Layout+ -> (H.Exp V a -> H.VertexOut clipDistances b) + -> N+convertFun1Vert = convertFun1 convertOpenVertexOut++convertFun1Geom :: (GPU a, GPU i, GPU b, GPU clipDistances)+ => Layout+ -> (H.Exp G a -> H.GeometryOut i clipDistances b) + -> N+convertFun1Geom = convertFun1 convertOpenGeometryOut++convertFun1Frag :: forall a b. GPU a+ => Layout+ -> (H.Exp F a -> H.FragmentOut b) + -> N+convertFun1Frag = convertFun1 convertOpenFragmentOut++convertFun1Exp :: forall stage a b. GPU a+ => Layout+ -> (H.Exp stage a -> H.Exp stage b) + -> N+convertFun1Exp = convertFun1 convertOpenExp++convertFun1 :: (GPU a)+ => (Layout -> b -> N) -> Layout -> (H.Exp stage a -> b) -> N+convertFun1 cvt lyt (f :: H.Exp stage t' -> b) = lam (genTy (undefined :: t')) $ body $ cvt lyt' (f a)+ where+ lyt' = []:lyt+ a = case f of+ (fv :: H.Exp stage t -> t2) -> H.Tag (length lyt) (show $ genTy (undefined :: t))++convertExp :: Layout -- array environment+ -> H.Exp stage t -- expression to be converted+ -> N+convertExp lyt = convertOpenExp lyt++convertTuple :: Layout+ -> Tuple (H.Exp stage) t + -> [N]+convertTuple _lyt NilTup = []+convertTuple lyt (es `SnocTup` e) = convertTuple lyt es ++ [convertOpenExp lyt e]++-- data type conversion+convertTextureDataType :: T.TextureDataType t ar -> TextureDataType+convertTextureDataType (T.Float a) = FloatT (T.toColorArity a)+convertTextureDataType (T.Int a) = IntT (T.toColorArity a)+convertTextureDataType (T.Word a) = WordT (T.toColorArity a)+convertTextureDataType T.Shadow = ShadowT++convertTextureType :: T.TextureType dim mip arr layerCount t ar -> TextureType+convertTextureType (T.Texture1D a b) = Texture1D (convertTextureDataType a) (toInt b)+convertTextureType (T.Texture2D a b) = Texture2D (convertTextureDataType a) (toInt b)+convertTextureType (T.Texture3D a) = Texture3D (convertTextureDataType a)+convertTextureType (T.TextureCube a) = TextureCube (convertTextureDataType a)+convertTextureType (T.TextureRect a) = TextureRect (convertTextureDataType a)+convertTextureType (T.Texture2DMS a b) = Texture2DMS (convertTextureDataType a) (toInt b)+convertTextureType (T.TextureBuffer a) = TextureBuffer (convertTextureDataType a)++convertMipMap :: T.MipMap t -> MipMap+convertMipMap (T.NoMip) = NoMip+convertMipMap (T.Mip a b) = Mip a b+convertMipMap (T.AutoMip a b) = AutoMip a b++convertRasterContext :: T.RasterContext p -> RasterContext+convertRasterContext (T.PointCtx a b c) = PointCtx a b c+convertRasterContext (T.LineCtx a b) = LineCtx a b+convertRasterContext (T.TriangleCtx a b c d) = TriangleCtx a b c d++convertBlending :: T.Blending c -> Blending+convertBlending T.NoBlending = NoBlending+convertBlending (T.BlendLogicOp a) = BlendLogicOp a+convertBlending (T.Blend a b c) = Blend a b c++convertFetchPrimitive :: T.FetchPrimitive a -> FetchPrimitive+convertFetchPrimitive v = case v of+ T.Points -> Points+ T.Lines -> Lines+ T.Triangles -> Triangles+ T.LinesAdjacency -> LinesAdjacency+ T.TrianglesAdjacency -> TrianglesAdjacency++convertOutputPrimitive :: T.OutputPrimitive a -> OutputPrimitive+convertOutputPrimitive v = case v of+ T.TrianglesOutput -> TrianglesOutput+ T.LinesOutput -> LinesOutput+ T.PointsOutput -> PointsOutput++convertAccumulationContext :: Layout -> H.AccumulationContext b -> N+convertAccumulationContext lyt (H.AccumulationContext vpSize ops) = accumulationContext (fmap (convertOpenExp []) vpSize) $ cvt ops+ where+ cvt :: FlatTuple T.NoConstraint T.FragmentOperation b -> [FragmentOperation]+ cvt ZT = []+ cvt (T.DepthOp a b:.xs) = DepthOp a b : cvt xs+ cvt (T.StencilOp a b c :. xs) = StencilOp a b c : cvt xs+ cvt (T.ColorOp a b :. xs) = ColorOp (convertBlending a) (T.toValue b) : cvt xs++convertFrameBuffer :: T.FrameBuffer layerCount t -> [Image]+convertFrameBuffer = cvt+ where+ cvt :: T.FrameBuffer layerCount t -> [Image]+ cvt ZT = []+ cvt (T.DepthImage a b:.xs) = DepthImage (toInt a) b : cvt xs+ cvt (T.StencilImage a b:.xs) = StencilImage (toInt a) b : cvt xs+ cvt (T.ColorImage a b:.xs) = ColorImage (toInt a) (T.toValue b) : cvt xs+ cvt (T.UnclearedImage a:.xs) = UnclearedImage (toInt a) : cvt xs
+ src/lib/LambdaCube/Language.hs view
@@ -0,0 +1,508 @@+{-# LANGUAGE UndecidableInstances, OverlappingInstances, OverloadedStrings #-}+module LambdaCube.Language where++import Data.Int+import Data.Word++import LambdaCube.Core.Type+import LambdaCube.Language.Type+import LambdaCube.Language.ReifyType+import LambdaCube.Language.PrimFun+import LambdaCube.Language.HOAS+{-+ all operatiors with @<>?,./\';""|:}{+_)0-=§±!@#$%^&*()_++ <+> <+.> <.+> -- good, conflict: <*>+ [+] [+.] [.+] -- good, conflict with lists+ |+| |+.| |.+| -- medium+ @+ @+. @.+ -- bad+ :+: :+.: :.+: -- bad+ [*]+-}+{-+infixl 7 .*., ./., .%.+infixl 6 .+., .-.+infix 4 .==., ./=., .<., .<=., .>=., .>.++infixr 3 .&&.+infixr 2 .||.++infixl 8 .>>., .<<.+infixl 7 .&.+infixl 6 .^.+infixl 5 .|.+-}++infixl 7 @*, @/, @%+infixl 6 @+, @-+infix 4 @==, @/=, @<, @<=, @>=, @>++infixr 3 @&&+infixr 2 @||++infixl 8 @>>, @<<+infixl 7 @&+infixl 6 @^+infixl 5 @|++infix 7 @. -- dot+infix 7 @# -- cross+infixr 7 @*. -- mulmv+infixl 7 @.* -- mulvm+infixl 7 @.*. -- mulmm++-- TODO: we should use template haskell or a preprocessor to generate the instances+class OperatorArithmetic a b where+ (@+) :: a -> b -> a+ (@-) :: a -> b -> a+ (@*) :: a -> b -> a++instance (GPU (V2 t), IsNumComponent t, IsMatVec (V2 t) c, IsNum c) => OperatorArithmetic (Exp stage (V2 t)) (Exp stage (V2 t)) where+ a @+ b = PrimApp PrimAdd $! tup2 (a,b)+ a @- b = PrimApp PrimSub $! tup2 (a,b)+ a @* b = PrimApp PrimMul $! tup2 (a,b)++instance (GPU (V3 t), IsNumComponent t, IsMatVec (V3 t) c, IsNum c) => OperatorArithmetic (Exp stage (V3 t)) (Exp stage (V3 t)) where+ a @+ b = PrimApp PrimAdd $! tup2 (a,b)+ a @- b = PrimApp PrimSub $! tup2 (a,b)+ a @* b = PrimApp PrimMul $! tup2 (a,b)++instance (GPU (V4 t), IsNumComponent t, IsMatVec (V4 t) c, IsNum c) => OperatorArithmetic (Exp stage (V4 t)) (Exp stage (V4 t)) where+ a @+ b = PrimApp PrimAdd $! tup2 (a,b)+ a @- b = PrimApp PrimSub $! tup2 (a,b)+ a @* b = PrimApp PrimMul $! tup2 (a,b)++instance (GPU c, GPU (V2 t), IsNumComponent t, IsMatVecScalar (V2 t) c, IsNum c) => OperatorArithmetic (Exp stage (V2 t)) (Exp stage c) where+ a @+ b = PrimApp PrimAddS $! tup2 (a,b)+ a @- b = PrimApp PrimSubS $! tup2 (a,b)+ a @* b = PrimApp PrimMulS $! tup2 (a,b)++instance (GPU c, GPU (V3 t), IsNumComponent t, IsMatVecScalar (V3 t) c, IsNum c) => OperatorArithmetic (Exp stage (V3 t)) (Exp stage c) where+ a @+ b = PrimApp PrimAddS $! tup2 (a,b)+ a @- b = PrimApp PrimSubS $! tup2 (a,b)+ a @* b = PrimApp PrimMulS $! tup2 (a,b)++instance (GPU c, GPU (V4 t), IsNumComponent t, IsMatVecScalar (V4 t) c, IsNum c) => OperatorArithmetic (Exp stage (V4 t)) (Exp stage c) where+ a @+ b = PrimApp PrimAddS $! tup2 (a,b)+ a @- b = PrimApp PrimSubS $! tup2 (a,b)+ a @* b = PrimApp PrimMulS $! tup2 (a,b)++instance (GPU a, GPU t, IsNum t, IsMatVecScalar a t) => OperatorArithmetic (Exp stage a) (Exp stage t) where+ a @+ b = PrimApp PrimAddS $! tup2 (a,b)+ a @- b = PrimApp PrimSubS $! tup2 (a,b)+ a @* b = PrimApp PrimMulS $! tup2 (a,b)++{-+instance (GPU a, IsNum t, IsMatVec a t) => OperatorArithmetic (Exp stage a) (Exp stage a) (Exp stage a) where+ a @+ b = PrimApp PrimAdd $! tup2 (a,b)+ a @- b = PrimApp PrimSub $! tup2 (a,b)+ a @* b = PrimApp PrimMul $! tup2 (a,b)++instance (GPU a, GPU t, IsNum t, IsMatVecScalar a t) => OperatorArithmetic (Exp stage a) (Exp stage t) (Exp stage a) where+ a @+ b = PrimApp PrimAddS $! tup2 (a,b)+ a @- b = PrimApp PrimSubS $! tup2 (a,b)+ a @* b = PrimApp PrimMulS $! tup2 (a,b)+-}+{-+instance OperatorArithmetic (Exp stage V4F) (Exp stage V4F) (Exp stage V4F) where+ a @+ b = PrimApp PrimAdd $! tup2 (a,b)+ a @- b = PrimApp PrimSub $! tup2 (a,b)+ a @* b = PrimApp PrimMul $! tup2 (a,b)++instance OperatorArithmetic (Exp stage V4F) (Exp stage Float) (Exp stage V4F) where+ a @+ b = PrimApp PrimAddS $! tup2 (a,b)+ a @- b = PrimApp PrimSubS $! tup2 (a,b)+ a @* b = PrimApp PrimMulS $! tup2 (a,b)+-}++-- FIXME: modulus % is defined only for integral types+class OperatorDivide a b where+ (@/) :: a -> b -> a+ (@%) :: a -> b -> a++instance (GPU a, IsNum t, IsVecScalar d a t) => OperatorDivide (Exp stage a) (Exp stage a) where+ a @/ b = PrimApp PrimDiv $! tup2 (a,b)+ a @% b = PrimApp PrimMod $! tup2 (a,b)++instance (GPU a, GPU t, IsNum t, IsVecScalar d a t) => OperatorDivide (Exp stage a) (Exp stage t) where+ a @/ b = PrimApp PrimDivS $! tup2 (a,b)+ a @% b = PrimApp PrimModS $! tup2 (a,b)++class OperatorBit a b where+ (@&) :: a -> b -> a+ (@|) :: a -> b -> a+ (@^) :: a -> b -> a++instance (GPU a, IsIntegral t, IsVecScalar d a t) => OperatorBit (Exp stage a) (Exp stage a) where+ a @& b = PrimApp PrimBAnd $! tup2 (a,b)+ a @| b = PrimApp PrimBOr $! tup2 (a,b)+ a @^ b = PrimApp PrimBXor $! tup2 (a,b)++instance (GPU a, GPU t, IsIntegral t, IsVecScalar d a t) => OperatorBit (Exp stage a) (Exp stage t) where+ a @& b = PrimApp PrimBAndS $! tup2 (a,b)+ a @| b = PrimApp PrimBOrS $! tup2 (a,b)+ a @^ b = PrimApp PrimBXorS $! tup2 (a,b)++class OperatorShift a b where+ (@>>) :: a -> b -> a+ (@<<) :: a -> b -> a++instance (GPU a, GPU b, IsIntegral t, IsVecScalar d a t, IsVecScalar d b Word32) => OperatorShift (Exp stage a) (Exp stage b) where+ a @>> b = PrimApp PrimBShiftR $! tup2 (a,b)+ a @<< b = PrimApp PrimBShiftL $! tup2 (a,b)++instance (GPU a, IsIntegral t, IsVecScalar d a t) => OperatorShift (Exp stage a) (Exp stage Word32) where+ a @>> b = PrimApp PrimBShiftRS $! tup2 (a,b)+ a @<< b = PrimApp PrimBShiftLS $! tup2 (a,b)++class OperatorEq a b where+ (@==) :: a -> a -> b+ (@/=) :: a -> a -> b++instance (GPU a, GPU b, IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => OperatorEq (Exp stage a) (Exp stage b) where+ a @== b = PrimApp PrimEqualV $! tup2 (a,b)+ a @/= b = PrimApp PrimNotEqualV $! tup2 (a,b)++instance (GPU a, IsMatVecScalar a t) => OperatorEq (Exp stage a) (Exp stage Bool) where+ a @== b = PrimApp PrimEqual $! tup2 (a,b)+ a @/= b = PrimApp PrimNotEqual $! tup2 (a,b)++class OperatorRelational a b where+ (@<=) :: a -> a -> b+ (@>=) :: a -> a -> b+ (@<) :: a -> a -> b+ (@>) :: a -> a -> b++instance (GPU a, GPU b, IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => OperatorRelational (Exp stage a) (Exp stage b) where+ a @<= b = PrimApp PrimLessThanEqual $! tup2 (a,b)+ a @>= b = PrimApp PrimGreaterThanEqual $! tup2 (a,b)+ a @< b = PrimApp PrimLessThan $! tup2 (a,b)+ a @> b = PrimApp PrimGreaterThan $! tup2 (a,b)++a @&& b = PrimApp PrimAnd $! tup2 (a,b)+a @|| b = PrimApp PrimOr $! tup2 (a,b)++xor' a b = PrimApp PrimXor $! tup2 (a,b)+not' a = PrimApp PrimNot a+any' a = PrimApp PrimAny a+all' a = PrimApp PrimAll a++acos' a = PrimApp PrimACos a+acosh' a = PrimApp PrimACosH a+asin' a = PrimApp PrimASin a+asinh' a = PrimApp PrimASinH a+atan' a = PrimApp PrimATan a+atan2' a b = PrimApp PrimATan2 $! tup2 (a,b)+atanh' a = PrimApp PrimATanH a+cos' a = PrimApp PrimCos a+cosh' a = PrimApp PrimCosH a+degrees' a = PrimApp PrimDegrees a+radians' a = PrimApp PrimRadians a+sin' a = PrimApp PrimSin a+sinh' a = PrimApp PrimSinH a+tan' a = PrimApp PrimTan a+tanh' a = PrimApp PrimTanH a++pow' a b = PrimApp PrimPow $! tup2 (a,b)+exp' a = PrimApp PrimExp a+log' a = PrimApp PrimLog a+exp2' a = PrimApp PrimExp2 a+log2' a = PrimApp PrimLog2 a+sqrt' a = PrimApp PrimSqrt a+invsqrt' a = PrimApp PrimInvSqrt a++isnan' a = PrimApp PrimIsNan a+isinf' a = PrimApp PrimIsInf a+abs' a = PrimApp PrimAbs a+sign' a = PrimApp PrimSign a+floor' a = PrimApp PrimFloor a+trunc' a = PrimApp PrimTrunc a+round' a = PrimApp PrimRound a+roundEven' a = PrimApp PrimRoundEven a+ceil' a = PrimApp PrimCeil a+fract' a = PrimApp PrimFract a++floatBitsToInt' a = PrimApp PrimFloatBitsToInt a+floatBitsToUint' a = PrimApp PrimFloatBitsToUInt a+intBitsToFloat' a = PrimApp PrimIntBitsToFloat a+uintBitsToFloat' a = PrimApp PrimUIntBitsToFloat a++length' a = PrimApp PrimLength a+distance' a b = PrimApp PrimDistance $! tup2 (a,b)+dot' a b = PrimApp PrimDot $! tup2 (a,b)+cross' a b = PrimApp PrimCross $! tup2 (a,b)+normalize' a = PrimApp PrimNormalize a+faceforward' a b c = PrimApp PrimFaceForward $! tup3 (a,b,c)+reflect' a b = PrimApp PrimReflect $! tup2 (a,b)+refract' a b c = PrimApp PrimRefract $! tup3 (a,b,c)++transpose' a = PrimApp PrimTranspose a+determinant' a = PrimApp PrimDeterminant a+inverse' a = PrimApp PrimInverse a+outerProduct' a b = PrimApp PrimOuterProduct $! tup2 (a,b)++dFdx' a = PrimApp PrimDFdx a+dFdy' a = PrimApp PrimDFdy a+fwidth' a = PrimApp PrimFWidth a++noise1' a = PrimApp PrimNoise1 a+noise2' a = PrimApp PrimNoise2 a+noise3' a = PrimApp PrimNoise3 a+noise4' a = PrimApp PrimNoise4 a++textureSize' a b = PrimApp PrimTextureSize $! tup2 (a,b)+texture' a b = PrimApp PrimTexture $! tup2 (a,b)+textureB' a b c = PrimApp PrimTextureB $! tup3 (a,b,c)+textureProj' a b = PrimApp PrimTextureProj $! tup2 (a,b)+textureProjB' a b c = PrimApp PrimTextureProjB $! tup3 (a,b,c)+textureLod' a b c = PrimApp PrimTextureLod $! tup3 (a,b,c)+textureOffset' a b c = PrimApp PrimTextureOffset $! tup3 (a,b,c)+textureOffsetB' a b c d = PrimApp PrimTextureOffsetB $! tup4 (a,b,c,d)+texelFetch' a b c = PrimApp PrimTexelFetch $! tup3 (a,b,c)+texelFetchOffset' a b c d = PrimApp PrimTexelFetchOffset $! tup4 (a,b,c,d)+textureProjOffset' a b c = PrimApp PrimTextureProjOffset $! tup3 (a,b,c)+textureProjOffsetB' a b c d = PrimApp PrimTextureProjOffsetB $! tup4 (a,b,c,d)+textureLodOffset' a b c d = PrimApp PrimTextureLodOffset $! tup4 (a,b,c,d)+textureProjLod' a b c = PrimApp PrimTextureProjLod $! tup3 (a,b,c)+textureProjLodOffset' a b c d = PrimApp PrimTextureProjLodOffset $! tup4 (a,b,c,d)+textureGrad' a b c d = PrimApp PrimTextureGrad $! tup4 (a,b,c,d)+textureGradOffset' a b c d e = PrimApp PrimTextureGradOffset $! tup5 (a,b,c,d,e)+textureProjGrad' a b c d = PrimApp PrimTextureProjGrad $! tup4 (a,b,c,d)+textureProjGradOffset' a b c d e = PrimApp PrimTextureProjGradOffset $! tup5 (a,b,c,d,e)++class BuiltinCommon a b where+ min' :: a -> b -> a+ max' :: a -> b -> a+ clamp' :: a -> b -> b -> a++instance (GPU a, IsNum t, IsVecScalar d a t) => BuiltinCommon (Exp stage a) (Exp stage a) where+ min' a b = PrimApp PrimMin $! tup2 (a,b)+ max' a b = PrimApp PrimMax $! tup2 (a,b)+ clamp' a b c = PrimApp PrimClamp $! tup3 (a,b,c)++instance (GPU a, GPU t, IsNum t, IsVecScalar d a t) => BuiltinCommon (Exp stage a) (Exp stage t) where+ min' a b = PrimApp PrimMinS $! tup2 (a,b)+ max' a b = PrimApp PrimMaxS $! tup2 (a,b)+ clamp' a b c = PrimApp PrimClampS $! tup3 (a,b,c)++class BuiltinMix a b where+ mix' :: a -> a -> b -> a++instance (GPU a, IsVecScalar d a Float) => BuiltinMix (Exp stage a) (Exp stage a) where+ mix' a b c = PrimApp PrimMix $! tup3 (a,b,c)++instance (GPU a, IsVecScalar d a Float) => BuiltinMix (Exp stage a) (Exp stage Float) where+ mix' a b c = PrimApp PrimMixS $! tup3 (a,b,c)++instance (GPU a, GPU b, IsVecScalar d a Float, IsVecScalar d b Bool) => BuiltinMix (Exp stage a) (Exp stage b) where+ mix' a b c = PrimApp PrimMixB $! tup3 (a,b,c)++class BuiltinStep a b where+ step' :: b -> a -> a+ smoothstep' :: b -> b -> a -> a++instance BuiltinStep (Exp stage V2F) (Exp stage V2F) where+ step' a b = PrimApp PrimStep $! tup2 (a,b)+ smoothstep' a b c = PrimApp PrimSmoothStep $! tup3 (a,b,c)++instance BuiltinStep (Exp stage V3F) (Exp stage V3F) where+ step' a b = PrimApp PrimStep $! tup2 (a,b)+ smoothstep' a b c = PrimApp PrimSmoothStep $! tup3 (a,b,c)++instance BuiltinStep (Exp stage V4F) (Exp stage V4F) where+ step' a b = PrimApp PrimStep $! tup2 (a,b)+ smoothstep' a b c = PrimApp PrimSmoothStep $! tup3 (a,b,c)++instance (GPU a, IsVecScalar d a Float) => BuiltinStep (Exp stage a) (Exp stage Float) where+ step' a b = PrimApp PrimStepS $! tup2 (a,b)+ smoothstep' a b c = PrimApp PrimSmoothStepS $! tup3 (a,b,c)++a @. b = dot' a b+a @# b = cross' a b+a @*. b = PrimApp PrimMulMatVec $! tup2 (a,b)+a @.* b = PrimApp PrimMulVecMat $! tup2 (a,b)+a @.*. b = PrimApp PrimMulMatMat $! tup2 (a,b)++complement' a = PrimApp PrimBNot a+neg' a = PrimApp PrimNeg a+modf' a = PrimApp PrimModF a++{-+data PrimFun sig where++ -- Vec/Mat (de)construction+ PrimTupToV2 :: IsComponent a => PrimFun ((a,a) -> V2 a)+ PrimTupToV3 :: IsComponent a => PrimFun ((a,a,a) -> V3 a)+ PrimTupToV4 :: IsComponent a => PrimFun ((a,a,a,a) -> V4 a)+ PrimV2ToTup :: IsComponent a => PrimFun (V2 a -> (a,a))+ PrimV3ToTup :: IsComponent a => PrimFun (V3 a -> (a,a,a))+ PrimV4ToTup :: IsComponent a => PrimFun (V4 a -> (a,a,a,a))+-}+--mkV2 a b = +--mkV3 +--mkV4++class SpecialConstant a where+ zero' :: a+ one' :: a++instance SpecialConstant Bool where+ zero' = False+ one' = True++instance SpecialConstant Int32 where+ zero' = 0+ one' = 1++instance SpecialConstant Word32 where+ zero' = 0+ one' = 1++instance SpecialConstant Float where+ zero' = 0+ one' = 1++instance (SpecialConstant a) => SpecialConstant (V2 a) where+ zero' = V2 zero' zero'+ one' = V2 one' one'++instance (SpecialConstant a) => SpecialConstant (V3 a) where+ zero' = V3 zero' zero' zero'+ one' = V3 one' one' one'++instance (SpecialConstant a) => SpecialConstant (V4 a) where+ zero' = V4 zero' zero' zero' zero'+ one' = V4 one' one' one' one'++class IdentityMatrix a where+ idmtx' :: a++instance IdentityMatrix M22F where+ idmtx' = V2 (V2 1 0) (V2 0 1)++instance IdentityMatrix M33F where+ idmtx' = V3 (V3 1 0 0) (V3 0 1 0) (V3 0 0 1)++instance IdentityMatrix M44F where+ idmtx' = V4 (V4 1 0 0 0) (V4 0 1 0 0) (V4 0 0 1 0) (V4 0 0 0 1)+{-+ TODO: + extendZero+ extendWith+ trim+-}++class PkgVec v where+ unpack' :: (GPU a, GPU (v a), IsComponent a)+ => Exp stage (v a) -> v (Exp stage a)++ pack' :: (GPU a, GPU (v a), IsComponent a)+ => v (Exp stage a) -> Exp stage (v a)++instance PkgVec V2 where+ unpack' v = let (x,y) = untup2 $! PrimApp PrimV2ToTup v in V2 x y+ pack' (V2 x y) = PrimApp PrimTupToV2 $! tup2 (x,y)++instance PkgVec V3 where+ unpack' v = let (x,y,z) = untup3 $! PrimApp PrimV3ToTup v in V3 x y z+ pack' (V3 x y z) = PrimApp PrimTupToV3 $! tup3 (x,y,z)++instance PkgVec V4 where+ unpack' v = let (x,y,z,w) = untup4 $! PrimApp PrimV4ToTup v in V4 x y z w+ pack' (V4 x y z w) = PrimApp PrimTupToV4 $! tup4 (x,y,z,w)++-- Smart constructor and destructors for tuples+--+tup0 :: Exp freq ()+tup0 = Tup NilTup++tup2 :: (GPU a, GPU b)+ => (Exp stage a, Exp stage b) -> Exp stage (a, b)+tup2 (x1, x2) = Tup (NilTup `SnocTup` x1 `SnocTup` x2)++tup3 :: (GPU a, GPU b, GPU c)+ => (Exp stage a, Exp stage b, Exp stage c) -> Exp stage (a, b, c)+tup3 (x1, x2, x3) = Tup (NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3)++tup4 :: (GPU a, GPU b, GPU c, GPU d)+ => (Exp stage a, Exp stage b, Exp stage c, Exp stage d) -> Exp stage (a, b, c, d)+tup4 (x1, x2, x3, x4) = Tup (NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4)++tup5 :: (GPU a, GPU b, GPU c, GPU d, GPU e)+ => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e) -> Exp stage (a, b, c, d, e)+tup5 (x1, x2, x3, x4, x5) = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5++tup6 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f)+ => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f) -> Exp stage (a, b, c, d, e, f)+tup6 (x1, x2, x3, x4, x5, x6) = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6++tup7 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g)+ => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g) -> Exp stage (a, b, c, d, e, f, g)+tup7 (x1, x2, x3, x4, x5, x6, x7)+ = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 `SnocTup` x7++tup8 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h)+ => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g, Exp stage h) -> Exp stage (a, b, c, d, e, f, g, h)+tup8 (x1, x2, x3, x4, x5, x6, x7, x8)+ = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 `SnocTup` x8++tup9 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h, GPU i)+ => (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g, Exp stage h, Exp stage i) -> Exp stage (a, b, c, d, e, f, g, h, i)+tup9 (x1, x2, x3, x4, x5, x6, x7, x8, x9)+ = Tup $! NilTup `SnocTup` x1 `SnocTup` x2 `SnocTup` x3 `SnocTup` x4 `SnocTup` x5 `SnocTup` x6 `SnocTup` x7 `SnocTup` x8 `SnocTup` x9++untup2 :: (GPU a, GPU b)+ => Exp stage (a, b) -> (Exp stage a, Exp stage b)+untup2 e = (tix1 `Prj` e, tix0 `Prj` e)++untup3 :: (GPU a, GPU b, GPU c)+ => Exp stage (a, b, c) -> (Exp stage a, Exp stage b, Exp stage c)+untup3 e = (tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e)++untup4 :: (GPU a, GPU b, GPU c, GPU d)+ => Exp stage (a, b, c, d) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d)+untup4 e = (tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e)++untup5 :: (GPU a, GPU b, GPU c, GPU d, GPU e)+ => Exp stage (a, b, c, d, e) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e)+untup5 e = (tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e)++untup6 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f)+ => Exp stage (a, b, c, d, e, f) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f)+untup6 e = (tix5 `Prj` e, tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e)++untup7 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g)+ => Exp stage (a, b, c, d, e, f, g) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g)+untup7 e = (tix6 `Prj` e, tix5 `Prj` e, tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e)++untup8 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h)+ => Exp stage (a, b, c, d, e, f, g, h) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g, Exp stage h)+untup8 e = (tix7 `Prj` e, tix6 `Prj` e, tix5 `Prj` e, tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e)++untup9 :: (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h, GPU i)+ => Exp stage (a, b, c, d, e, f, g, h, i) -> (Exp stage a, Exp stage b, Exp stage c, Exp stage d, Exp stage e, Exp stage f, Exp stage g, Exp stage h, Exp stage i)+untup9 e = (tix8 `Prj` e, tix7 `Prj` e, tix6 `Prj` e, tix5 `Prj` e, tix4 `Prj` e, tix3 `Prj` e, tix2 `Prj` e, tix1 `Prj` e, tix0 `Prj` e)++-- builtin variables+-- vertex shader+vertexID' :: Exp V Int32+vertexID' = PrimVar $ IInt "gl_VertexID"++instanceID' :: Exp V Int32+instanceID' = PrimVar $ IInt "gl_InstanceID"++-- geometry shader+primitiveIDIn' :: Exp G Int32+primitiveIDIn' = PrimVar $ IInt "gl_PrimitiveIDIn"++-- fragment shader+fragCoord' :: Exp F V4F+fragCoord' = PrimVar $ IV4F "gl_FragCoord"++frontFacing' :: Exp F Bool+frontFacing' = PrimVar $ IBool "gl_FrontFacing"++pointCoord' :: Exp F V2F+pointCoord' = PrimVar $ IV2F "gl_PointCoord"++primitiveID' :: Exp F Int32+primitiveID' = PrimVar $ IInt "gl_PrimitiveID"
+ src/lib/LambdaCube/Language/HOAS.hs view
@@ -0,0 +1,270 @@+module LambdaCube.Language.HOAS where++import GHC.TypeLits++import Data.ByteString.Char8+import Data.Int++import LambdaCube.Core.Type hiding (FetchPrimitive, OutputPrimitive, Blending, RasterContext, Blend, TriangleCtx, Image, FragmentOperation, MipMap, TextureDataType, TextureType)+import LambdaCube.Language.Type+import LambdaCube.Language.ReifyType+import LambdaCube.Language.PrimFun+import Data.Typeable+import Data.Dynamic+import qualified LambdaCube.Core.DeBruijn as U (N)++-- Common Exp, describes shader functions+data Exp :: Frequency -> * -> * where++ Tag :: GPU t+ => Int+ -> String+ -> Exp stage t++ -- Needed for Let conversion+ Shr :: U.N+ -> Exp stage t++ Let :: (GPU a, GPU b)+ => Exp stage a+ -> (Exp stage a -> Exp stage b)+ -> Exp stage b++ -- Needed for conversion to de Bruijn form+ Var :: GPU t+ => Dynamic+ -> Exp stage t+ -- environment size at defining occurrence+{-+ -- function support+ Lam :: (GPU a, GPU b)+ => (Exp stage a -> Exp stage b)+ -> Exp stage (a -> b)++ App :: (GPU a, GPU b)+ => Exp stage a+ -> Exp stage (a -> b)+ -> Exp stage b+-}+ -- constant value+ Const :: (GPU t,IsScalar t)+ => t+ -> Exp stage t++ -- builtin variable+ PrimVar :: GPU t+ => Input t+ -> Exp stage t++ -- uniform value+ Uni :: GPU t+ => Input t+ -> Exp stage t++ -- conditional expression+ Cond :: GPU t+ => Exp stage Bool+ -> Exp stage t+ -> Exp stage t+ -> Exp stage t++ PrimApp :: (GPU a, GPU r)+ => PrimFun stage (a -> r)+ -> Exp stage a+ -> Exp stage r++ -- tuple support+ Tup :: (GPU t, IsTuple t)+ => Tuple (Exp stage) (TupleRepr t)+ -> Exp stage t++ Prj :: (GPU e, GPU t, IsTuple t)+ => TupleIdx (TupleRepr t) e+ -> Exp stage t+ -> Exp stage e++ -- sampler support+ Sampler :: GPU (Sampler dim arr t ar)+ => Filter+ -> EdgeMode+ -> Exp Obj (Texture dim arr t ar)+ -> Exp stage (Sampler dim arr t ar)++ TextureSlot :: (IsValidTextureSlot t)+ => ByteString -- texture slot name+ -> TextureType dim mip arr layerCount t ar+ -> Exp Obj (Texture dim arr t ar)+ -- TODO:+ -- add texture internal format specification+ Texture :: (IsScalar (TexSizeRepr dim), IsMipValid canMip mip {- ,Typeable (TexDataRepr ar t), Typeable (TextureType dim canMip arr layerCount t ar), Typeable (Image layerCount (TexDataRepr ar t))-})+ => TextureType dim canMip arr layerCount t ar+ -> TexSizeRepr dim+ -> MipMap mip+-- -> TexRepr dim mip gp layerCount (TexDataRepr ar t) -- FIXME: for cube it will give wrong type+ -> [Exp Obj (Image layerCount (TexDataRepr ar t))]+ -> Exp Obj (Texture dim arr t ar)++ -- loop support+ Loop :: (GPU s, GPU a{-, Typeable stage-})+ => (Exp stage s -> Exp stage s) -- state transform function+ -> (Exp stage s -> Exp stage Bool) -- loop condition function+ -> (Exp stage s -> Exp stage a) -- state to result transform function+ -> Exp stage s -- initial state+ -> Exp stage a -- result+ -- GP+ -- hint: GP stands for Graphics Pipeline+ Fetch :: (InputTuple a, SGPU (InputTupleRepr a))+ => ByteString+ -> FetchPrimitive primitive+ -> a+ -> Exp Obj (VertexStream primitive (InputTupleRepr a))++ Transform :: (GPU a, GPU b{-, Typeable clipDistances-})+ => (Exp V a -> VertexOut clipDistances b) -- vertex shader+ -> Exp Obj (VertexStream primitive a)+ -> Exp Obj (PrimitiveStream primitive clipDistances 1 V b)++ Reassemble :: GeometryShader inputPrimitive outputPrimitive inputClipDistances outputClipDistances layerCount a b+ -> Exp Obj (PrimitiveStream inputPrimitive inputClipDistances 1 V a)+ -> Exp Obj (PrimitiveStream outputPrimitive outputClipDistances layerCount G b)++ Rasterize :: RasterContext primitive+ -> Exp Obj (PrimitiveStream primitive clipDistances layerCount freq a)+ -> Exp Obj (FragmentStream layerCount a)++ FrameBuffer :: FrameBuffer layerCount t+ -> Exp Obj (FrameBuffer layerCount (FTRepr' t))++ Accumulate :: ({-Typeable (NoStencilRepr b), -}GPU a, GPU (FTRepr' b), IsValidOutput b) -- restriction: depth and stencil optional, arbitrary color component+ => AccumulationContext b+ -> FragmentFilter a+ -> (Exp F a -> FragmentOut (NoStencilRepr b)) -- fragment shader+ -> Exp Obj (FragmentStream layerCount a)+ -> Exp Obj (FrameBuffer layerCount (FTRepr' b))+ -> Exp Obj (FrameBuffer layerCount (FTRepr' b))++ PrjFrameBuffer :: ByteString -- internal image output (can be allocated on request)+ -> TupleIdx (EltRepr b) t+ -> Exp Obj (FrameBuffer layerCount b)+ -> Exp Obj (Image layerCount t)++ PrjImage :: ((idx + 1) <= layerCount, 2 <= layerCount, KnownNat idx)+ => ByteString -- internal image output (can be allocated on request)+ -> NatNum idx+ -> Exp Obj (Image layerCount t)+ -> Exp Obj (Image 1 t)+{-+ -- dynamic extension support+ AccumulateSet :: GPU a+ => ByteString+ -> Exp Obj (FrameBuffer layerCount a)+ -> Exp Obj (FrameBuffer layerCount a)+-}++type InterpolatedFlatExp stage a = FlatTuple GPU (Interpolated (Exp stage)) a+type FlatExp stage a = FlatTuple GPU (Exp stage) a++-- Vertex+{-+ Vertex shader builtin output:+ gl_PerVertex {+ vec4 gl_Position+ float gl_PointSize+ float gl_ClipDistance[]+ }+-}+-- result of a vertex or geometry shader function+data VertexOut clipDistances t where+ VertexOut :: IsFloatTuple clipDistances+ => Exp V V4F -- position+ -> Exp V Float -- point size+ -> FlatExp V clipDistances -- clip distance []+ -> InterpolatedFlatExp V a+ -> VertexOut (FTRepr clipDistances) (FTRepr a)+-- Geometry+-- describes a geometry shader+data GeometryShader (inPrimitive :: PrimitiveType) (outPrimitive :: PrimitiveType) inClipDistances outClipDistances (layerCount :: Nat) a b where+ GeometryShader :: (GPU j, GPU i, GPU b, GPU outputClipDistances, GPU input, KnownNat layerCount+ , inputVertex ~ (V4F,Float,inputClipDistances,a)+ , input ~ PrimitiveVertices inputPrimitive inputVertex+ )+ => NatNum layerCount -- geometry shader:+ -> OutputPrimitive outputPrimitive -- output primitive+ -> Int -- max amount of generated vertices+ -> (Exp G input -> Exp G (i,Int32)) -- how many primitives?+ -> (Exp G i -> Exp G (Int32,Int32,i,j,Int32)) -- how many vertices? primtive loop, out:+ -- gl_PrimitiveID; gl_Layer; loop var; vertex loop seed; vertex loop iteration count)+ -> (Exp G j -> GeometryOut j outputClipDistances b) -- generate vertices+ -> GeometryShader inputPrimitive outputPrimitive inputClipDistances outputClipDistances layerCount a b+{-+ GeometryShader :: (GPU (PrimitiveVertices primIn a), GPU i, GPU j, GPU b, IsPrimitive primIn, IsPrimitive primOut, KnownNat layerNum)+ => NatNum layerNum -- geometry shader:+ -> primOut -- output primitive+ -> Int -- max amount of generated vertices+ -> (Exp G (PrimitiveVertices primIn a) -> Exp G (i,Int32)) -- how many primitives?+ -> (Exp G i -> Exp G (i,j,Int32)) -- how many vertices?+ -> (Exp G j -> GeometryOut (j,b)) -- generate vertices+ -> GeometryShader primIn primOut layerNum a b+-}++{-+ Geometry shader builtin output:+ gl_PerVertex {+ vec4 gl_Position+ float gl_PointSize+ float gl_ClipDistance[]+ }+ int gl_PrimitiveID+ int gl_Layer+-}+-- result of a geometry shader function+data GeometryOut i clipDistances t where+ GeometryOut :: IsFloatTuple clipDistances+ => Exp G i+ -> Exp G V4F -- position+ -> Exp G Float -- point size+ -> FlatExp G clipDistances -- clip distance []+ -> InterpolatedFlatExp G a+ -> GeometryOut i (FTRepr clipDistances) (FTRepr a)++-- Fragment+{-+ Fragment shader builtin output:+ float gl_FragDepth -- Optional+-}+-- result of a fragment shader function+data FragmentOut t where+ FragmentOut :: FlatExp F a+ -> FragmentOut (ColorRepr a)++ FragmentOutDepth :: Exp F Float+ -> FlatExp F a+ -> FragmentOut (Depth Float :+: ColorRepr a)++ FragmentOutRastDepth :: FlatExp F a+ -> FragmentOut (Depth Float :+: ColorRepr a)++-- fragment filter function, we express discard using a filter function+data FragmentFilter a where+ PassAll :: FragmentFilter a++ Filter :: (Exp F a -> Exp F Bool)+ -> FragmentFilter a++data GPOutput (o :: OutputType) where+ SamplerOut :: GPU (Sampler dim arr t ar)+ => ByteString+ -> Exp Obj (Sampler dim arr t ar)+ -> GPOutput SingleOutput++ ScreenOut :: Exp Obj (Image 1 t)+ -> GPOutput SingleOutput++ MultiOut :: [GPOutput SingleOutput]+ -> GPOutput MultiOutput++data AccumulationContext t+ = AccumulationContext+ { accViewportSize :: Maybe (Exp Obj V4U)+ , accOperations :: FlatTuple NoConstraint FragmentOperation t+ }
+ src/lib/LambdaCube/Language/PrimFun.hs view
@@ -0,0 +1,172 @@+module LambdaCube.Language.PrimFun where++import Data.Int+import Data.Word++import LambdaCube.Core.Type+import LambdaCube.Language.Sampler+import LambdaCube.Language.Type++data PrimFun stage sig where++ -- Vec/Mat (de)construction+ PrimTupToV2 :: IsComponent a => PrimFun stage ((a,a) -> V2 a)+ PrimTupToV3 :: IsComponent a => PrimFun stage ((a,a,a) -> V3 a)+ PrimTupToV4 :: IsComponent a => PrimFun stage ((a,a,a,a) -> V4 a)+ PrimV2ToTup :: IsComponent a => PrimFun stage (V2 a -> (a,a))+ PrimV3ToTup :: IsComponent a => PrimFun stage (V3 a -> (a,a,a))+ PrimV4ToTup :: IsComponent a => PrimFun stage (V4 a -> (a,a,a,a))++ -- Arithmetic Functions (componentwise)+ PrimAdd :: (IsNum t, IsMatVec a t) => PrimFun stage ((a,a) -> a)+ PrimAddS :: (IsNum t, IsMatVecScalar a t) => PrimFun stage ((a,t) -> a)+ PrimSub :: (IsNum t, IsMatVec a t) => PrimFun stage ((a,a) -> a)+ PrimSubS :: (IsNum t, IsMatVecScalar a t) => PrimFun stage ((a,t) -> a)+ PrimMul :: (IsNum t, IsMatVec a t) => PrimFun stage ((a,a) -> a)+ PrimMulS :: (IsNum t, IsMatVecScalar a t) => PrimFun stage ((a,t) -> a)+ PrimDiv :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a)+ PrimDivS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a)+ PrimNeg :: (IsSigned t, IsMatVecScalar a t) => PrimFun stage (a -> a)+ PrimMod :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a)+ PrimModS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a)++ -- Bit-wise Functions+ PrimBAnd :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a)+ PrimBAndS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a)+ PrimBOr :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a)+ PrimBOrS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a)+ PrimBXor :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a)+ PrimBXorS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a)+ PrimBNot :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage (a -> a)+ PrimBShiftL :: (IsIntegral t, IsVecScalar d a t, IsVecScalar d b Word32) => PrimFun stage ((a, b) -> a)+ PrimBShiftLS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a, Word32) -> a)+ PrimBShiftR :: (IsIntegral t, IsVecScalar d a t, IsVecScalar d b Word32) => PrimFun stage ((a, b) -> a)+ PrimBShiftRS :: (IsIntegral t, IsVecScalar d a t) => PrimFun stage ((a, Word32) -> a)++ -- Logic Functions+ PrimAnd :: PrimFun stage ((Bool,Bool) -> Bool)+ PrimOr :: PrimFun stage ((Bool,Bool) -> Bool)+ PrimXor :: PrimFun stage ((Bool,Bool) -> Bool)+ PrimNot :: IsVecScalar d a Bool => PrimFun stage (a -> a)+ PrimAny :: IsVecScalar d a Bool => PrimFun stage (a -> Bool)+ PrimAll :: IsVecScalar d a Bool => PrimFun stage (a -> Bool)++ -- Angle and Trigonometry Functions+ PrimACos :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimACosH :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimASin :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimASinH :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimATan :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimATan2 :: IsVecScalar d a Float => PrimFun stage ((a,a) -> a)+ PrimATanH :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimCos :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimCosH :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimDegrees :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimRadians :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimSin :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimSinH :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimTan :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimTanH :: IsVecScalar d a Float => PrimFun stage (a -> a)++ -- Exponential Functions+ PrimPow :: IsVecScalar d a Float => PrimFun stage ((a,a) -> a)+ PrimExp :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimLog :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimExp2 :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimLog2 :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimSqrt :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimInvSqrt :: IsVecScalar d a Float => PrimFun stage (a -> a)++ -- Common Functions+ PrimIsNan :: (IsVecScalar d a Float, IsVecScalar d b Bool) => PrimFun stage (a -> b)+ PrimIsInf :: (IsVecScalar d a Float, IsVecScalar d b Bool) => PrimFun stage (a -> b)+ PrimAbs :: (IsSigned t, IsVecScalar d a t) => PrimFun stage (a -> a)+ PrimSign :: (IsSigned t, IsVecScalar d a t) => PrimFun stage (a -> a)+ PrimFloor :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimTrunc :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimRound :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimRoundEven :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimCeil :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimFract :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimModF :: IsVecScalar d a Float => PrimFun stage (a -> (a,a))+ PrimMin :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a)+ PrimMinS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a)+ PrimMax :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a) -> a)+ PrimMaxS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t) -> a)+ PrimClamp :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,a,a) -> a)+ PrimClampS :: (IsNum t, IsVecScalar d a t) => PrimFun stage ((a,t,t) -> a)+ PrimMix :: IsVecScalar d a Float => PrimFun stage ((a,a,a) -> a)+ PrimMixS :: IsVecScalar d a Float => PrimFun stage ((a,a,Float) -> a)+ PrimMixB :: (IsVecScalar d a Float, IsVecScalar d b Bool) => PrimFun stage ((a,a,b) -> a)+ PrimStep :: IsVec d a Float => PrimFun stage ((a,a) -> a)+ PrimStepS :: IsVecScalar d a Float => PrimFun stage ((Float,a) -> a)+ PrimSmoothStep :: IsVec d a Float => PrimFun stage ((a,a,a) -> a)+ PrimSmoothStepS :: IsVecScalar d a Float => PrimFun stage ((Float,Float,a) -> a)++ -- Integer/Float Conversion Functions+ PrimFloatBitsToInt :: (IsVecScalar d fv Float, IsVecScalar d iv Int32) => PrimFun stage (fv -> iv)+ PrimFloatBitsToUInt :: (IsVecScalar d fv Float, IsVecScalar d uv Word32) => PrimFun stage (fv -> uv)+ PrimIntBitsToFloat :: (IsVecScalar d fv Float, IsVecScalar d iv Int32) => PrimFun stage (iv -> fv)+ PrimUIntBitsToFloat :: (IsVecScalar d fv Float, IsVecScalar d uv Word32) => PrimFun stage (uv -> fv)++ -- Geometric Functions+ PrimLength :: IsVecScalar d a Float => PrimFun stage (a -> Float)+ PrimDistance :: IsVecScalar d a Float => PrimFun stage ((a,a) -> Float)+ PrimDot :: IsVecScalar d a Float => PrimFun stage ((a,a) -> Float)+ PrimCross :: IsVecScalar 3 a Float => PrimFun stage ((a,a) -> a)+ PrimNormalize :: IsVecScalar d a Float => PrimFun stage (a -> a)+ PrimFaceForward :: IsVecScalar d a Float => PrimFun stage ((a,a,a) -> a)+ PrimReflect :: IsVecScalar d a Float => PrimFun stage ((a,a) -> a)+ PrimRefract :: IsVecScalar d a Float => PrimFun stage ((a,a,a) -> a)++ -- Matrix Functions+ PrimTranspose :: (IsMat a h w, IsMat b w h) => PrimFun stage (a -> b)+ PrimDeterminant :: IsMat m s s => PrimFun stage (m -> Float)+ PrimInverse :: IsMat m h w => PrimFun stage (m -> m)+ PrimOuterProduct :: IsMat m h w => PrimFun stage ((w,h) -> m)+ PrimMulMatVec :: IsMat m h w => PrimFun stage ((m,w) -> h)+ PrimMulVecMat :: IsMat m h w => PrimFun stage ((h,m) -> w)+ PrimMulMatMat :: (IsMat a i j, IsMat b j k, IsMat c i k) => PrimFun stage ((a,b) -> c)++ -- Vector and Scalar Relational Functions+ PrimLessThan :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b)+ PrimLessThanEqual :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b)+ PrimGreaterThan :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b)+ PrimGreaterThanEqual :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b)+ PrimEqualV :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b)+ PrimEqual :: IsMatVecScalar a t => PrimFun stage ((a,a) -> Bool)+ PrimNotEqualV :: (IsNum t, IsVecScalar d a t, IsVecScalar d b Bool) => PrimFun stage ((a,a) -> b)+ PrimNotEqual :: IsMatVecScalar a t => PrimFun stage ((a,a) -> Bool)++ -- Fragment Processing Functions+ PrimDFdx :: IsVecScalar d a Float => PrimFun F (a -> a)+ PrimDFdy :: IsVecScalar d a Float => PrimFun F (a -> a)+ PrimFWidth :: IsVecScalar d a Float => PrimFun F (a -> a)++ -- Noise Functions+ PrimNoise1 :: IsVecScalar d a Float => PrimFun stage (a -> Float)+ PrimNoise2 :: (IsVecScalar d a Float, IsVecScalar 2 b Float) => PrimFun stage (a -> b)+ PrimNoise3 :: (IsVecScalar d a Float, IsVecScalar 3 b Float) => PrimFun stage (a -> b)+ PrimNoise4 :: (IsVecScalar d a Float, IsVecScalar 4 b Float) => PrimFun stage (a -> b)++ -- Texture Lookup Functions+ PrimTextureSize :: IsTextureSize sampler lod size => PrimFun stage ((sampler,lod) -> size)+ PrimTexture :: IsTexture sampler coord bias => PrimFun stage ((sampler,coord) -> TexelRepr sampler)+ PrimTextureB :: IsTexture sampler coord bias => PrimFun F ((sampler,coord,bias) -> TexelRepr sampler)+ PrimTextureProj :: IsTextureProj sampler coord bias => PrimFun stage ((sampler,coord) -> TexelRepr sampler)+ PrimTextureProjB :: IsTextureProj sampler coord bias => PrimFun F ((sampler,coord,bias) -> TexelRepr sampler)+ PrimTextureLod :: IsTextureLod sampler coord lod => PrimFun stage ((sampler,coord,lod) -> TexelRepr sampler)+ PrimTextureOffset :: IsTextureOffset sampler coord offset bias => PrimFun stage ((sampler,coord,offset) -> TexelRepr sampler)+ PrimTextureOffsetB :: IsTextureOffset sampler coord offset bias => PrimFun F ((sampler,coord,offset,bias) -> TexelRepr sampler)+ PrimTexelFetch :: IsTexelFetch sampler coord lod => PrimFun stage ((sampler,coord,lod) -> TexelRepr sampler)+ PrimTexelFetchOffset :: IsTexelFetchOffset sampler coord lod offset => PrimFun stage ((sampler,coord,lod,offset) -> TexelRepr sampler)+ PrimTextureProjOffset :: IsTextureProjOffset sampler coord offset bias => PrimFun stage ((sampler,coord,offset) -> TexelRepr sampler)+ PrimTextureProjOffsetB :: IsTextureProjOffset sampler coord offset bias => PrimFun F ((sampler,coord,offset,bias) -> TexelRepr sampler)+ PrimTextureLodOffset :: IsTextureLodOffset sampler coord lod offset => PrimFun stage ((sampler,coord,lod,offset) -> TexelRepr sampler)+ PrimTextureProjLod :: IsTextureProjLod sampler coord lod => PrimFun stage ((sampler,coord,lod) -> TexelRepr sampler)+ PrimTextureProjLodOffset :: IsTextureProjLodOffset sampler coord lod offset => PrimFun stage ((sampler,coord,lod,offset) -> TexelRepr sampler)+ PrimTextureGrad :: IsTextureGrad sampler coord dx dy => PrimFun stage ((sampler,coord,dx,dy) -> TexelRepr sampler)+ PrimTextureGradOffset :: IsTextureGradOffset sampler coord dx dy offset => PrimFun stage ((sampler,coord,dx,dy,offset) -> TexelRepr sampler)+ PrimTextureProjGrad :: IsTextureProjGrad sampler coord dx dy => PrimFun stage ((sampler,coord,dx,dy) -> TexelRepr sampler)+ PrimTextureProjGradOffset :: IsTextureProjGradOffset sampler coord dx dy offset => PrimFun stage ((sampler,coord,dx,dy,offset) -> TexelRepr sampler)+
+ src/lib/LambdaCube/Language/ReifyType.hs view
@@ -0,0 +1,640 @@+module LambdaCube.Language.ReifyType where++import Data.Int+import Data.Word+import Data.Typeable++import LambdaCube.Core.Type+import qualified LambdaCube.Core.Type as U++data TextureShape+ = Tex1D+ | Tex2D+ | Tex3D+ | TexRect++deriving instance Typeable Tex1D+deriving instance Typeable Tex2D+deriving instance Typeable Tex3D+deriving instance Typeable TexRect++data Red = Red deriving (Typeable,Eq,Ord)+data RG = RG deriving (Typeable,Eq,Ord)+data RGB = RGB deriving (Typeable,Eq,Ord)+data RGBA = RGBA deriving (Typeable,Eq,Ord)++data TextureSemantics a+ = Regular a+ | Shadow a+ | MultiSample a+ | Buffer a++deriving instance Typeable Regular+deriving instance Typeable Shadow+deriving instance Typeable MultiSample+deriving instance Typeable Buffer++data TextureArray+ = SingleTex -- singleton texture+ | ArrayTex -- array texture+ | CubeTex -- cube texture = array with size 6++deriving instance Typeable SingleTex+deriving instance Typeable ArrayTex+deriving instance Typeable CubeTex++--data Sampler dim layerCount t ar+data Sampler :: TextureShape -> TextureArray -> TextureSemantics * -> * -> *++deriving instance Typeable Sampler++-- IsScalar means here that the related type is not a tuple, but a GPU primitive type+class GPU a => IsScalar a where+ toValue :: a -> Value+ toType :: a -> InputType+{-+instance Nat sh => IsScalar (Sampler dim sh t ar) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = error "toType Sampler is not implemented yet" -- TODO+-}+-- Float+instance (Typeable a) => IsScalar (Sampler Tex1D SingleTex (Regular Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTexture1D+instance (Typeable a) => IsScalar (Sampler Tex2D SingleTex (Regular Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTexture2D+instance (Typeable a) => IsScalar (Sampler Tex3D SingleTex (Regular Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTexture3D+instance (Typeable a) => IsScalar (Sampler Tex2D CubeTex (Regular Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTextureCube+instance (Typeable a) => IsScalar (Sampler Tex1D ArrayTex (Regular Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTexture1DArray+instance (Typeable a) => IsScalar (Sampler Tex2D ArrayTex (Regular Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTexture2DArray+instance (Typeable a) => IsScalar (Sampler Tex2D SingleTex (MultiSample Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTexture2DMS+instance (Typeable a) => IsScalar (Sampler Tex2D ArrayTex (MultiSample Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTexture2DMSArray+instance (Typeable a) => IsScalar (Sampler Tex1D SingleTex (Buffer Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTextureBuffer+instance (Typeable a) => IsScalar (Sampler TexRect SingleTex (Regular Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.FTexture2DRect++-- Int+instance (Typeable a) => IsScalar (Sampler Tex1D SingleTex (Regular Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITexture1D+instance (Typeable a) => IsScalar (Sampler Tex2D SingleTex (Regular Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITexture2D+instance (Typeable a) => IsScalar (Sampler Tex3D SingleTex (Regular Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITexture3D+instance (Typeable a) => IsScalar (Sampler Tex2D CubeTex (Regular Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITextureCube+instance (Typeable a) => IsScalar (Sampler Tex1D ArrayTex (Regular Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITexture1DArray+instance (Typeable a) => IsScalar (Sampler Tex2D ArrayTex (Regular Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITexture2DArray+instance (Typeable a) => IsScalar (Sampler Tex2D SingleTex (MultiSample Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITexture2DMS+instance (Typeable a) => IsScalar (Sampler Tex2D ArrayTex (MultiSample Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITexture2DMSArray+instance (Typeable a) => IsScalar (Sampler Tex1D SingleTex (Buffer Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITextureBuffer+instance (Typeable a) => IsScalar (Sampler TexRect SingleTex (Regular Int) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.ITexture2DRect++-- Word+instance (Typeable a) => IsScalar (Sampler Tex1D SingleTex (Regular Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTexture1D+instance (Typeable a) => IsScalar (Sampler Tex2D SingleTex (Regular Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTexture2D+instance (Typeable a) => IsScalar (Sampler Tex3D SingleTex (Regular Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTexture3D+instance (Typeable a) => IsScalar (Sampler Tex2D CubeTex (Regular Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTextureCube+instance (Typeable a) => IsScalar (Sampler Tex1D ArrayTex (Regular Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTexture1DArray+instance (Typeable a) => IsScalar (Sampler Tex2D ArrayTex (Regular Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTexture2DArray+instance (Typeable a) => IsScalar (Sampler Tex2D SingleTex (MultiSample Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTexture2DMS+instance (Typeable a) => IsScalar (Sampler Tex2D ArrayTex (MultiSample Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTexture2DMSArray+instance (Typeable a) => IsScalar (Sampler Tex1D SingleTex (Buffer Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTextureBuffer+instance (Typeable a) => IsScalar (Sampler TexRect SingleTex (Regular Word) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.UTexture2DRect++-- Shadow+instance (Typeable a) => IsScalar (Sampler Tex1D SingleTex (Shadow Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.STexture1D+instance (Typeable a) => IsScalar (Sampler Tex2D SingleTex (Shadow Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.STexture2D+instance (Typeable a) => IsScalar (Sampler Tex2D CubeTex (Shadow Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.STextureCube+instance (Typeable a) => IsScalar (Sampler Tex1D ArrayTex (Shadow Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.STexture1DArray+instance (Typeable a) => IsScalar (Sampler Tex2D ArrayTex (Shadow Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.STexture2DArray+instance (Typeable a) => IsScalar (Sampler TexRect SingleTex (Shadow Float) a) where+ toValue v = error "toValue Sampler is not implemented yet" -- TODO+ toType _ = U.STexture2DRect++instance IsScalar Int32 where+ toValue v = VInt v+ toType _ = U.Int+instance IsScalar Word32 where+ toValue v = VWord v+ toType _ = U.Word+instance IsScalar Float where+ toValue v = VFloat v+ toType _ = U.Float+instance IsScalar Bool where+ toValue v = VBool v+ toType _ = U.Bool+instance IsScalar M22F where+ toValue v = VM22F v+ toType _ = U.M22F+instance IsScalar M23F where+ toValue v = VM23F v+ toType _ = U.M23F+instance IsScalar M24F where+ toValue v = VM24F v+ toType _ = U.M24F+instance IsScalar M32F where+ toValue v = VM32F v+ toType _ = U.M32F+instance IsScalar M33F where+ toValue v = VM33F v+ toType _ = U.M33F+instance IsScalar M34F where+ toValue v = VM34F v+ toType _ = U.M34F+instance IsScalar M42F where+ toValue v = VM42F v+ toType _ = U.M42F+instance IsScalar M43F where+ toValue v = VM43F v+ toType _ = U.M43F+instance IsScalar M44F where+ toValue v = VM44F v+ toType _ = U.M44F+instance IsScalar V2F where+ toValue v = VV2F v+ toType _ = U.V2F+instance IsScalar V3F where+ toValue v = VV3F v+ toType _ = U.V3F+instance IsScalar V4F where+ toValue v = VV4F v+ toType _ = U.V4F+instance IsScalar V2I where+ toValue v = VV2I v+ toType _ = U.V2I+instance IsScalar V3I where+ toValue v = VV3I v+ toType _ = U.V3I+instance IsScalar V4I where+ toValue v = VV4I v+ toType _ = U.V4I+instance IsScalar V2U where+ toValue v = VV2U v+ toType _ = U.V2U+instance IsScalar V3U where+ toValue v = VV3U v+ toType _ = U.V3U+instance IsScalar V4U where+ toValue v = VV4U v+ toType _ = U.V4U+instance IsScalar V2B where+ toValue v = VV2B v+ toType _ = U.V2B+instance IsScalar V3B where+ toValue v = VV3B v+ toType _ = U.V3B+instance IsScalar V4B where+ toValue v = VV4B v+ toType _ = U.V4B++instance Show (Sampler dim layerCount t ar) where+ show _ = "Sampler dim layerCount t ar"++-- GPU type restriction, the functions are used in shader codegen+class (Show a, Typeable a) => GPU a where+ tupleType :: a -> Ty++-- Float+instance (Typeable a) => GPU (Sampler Tex1D SingleTex (Regular Float) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex2D SingleTex (Regular Float) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex3D SingleTex (Regular Float) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex2D CubeTex (Regular Float) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex1D ArrayTex (Regular Float) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex2D ArrayTex (Regular Float) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex2D SingleTex (MultiSample Float) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex2D ArrayTex (MultiSample Float) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex1D SingleTex (Buffer Float) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler TexRect SingleTex (Regular Float) a) where+ tupleType v = Single $ toType v++-- Int+instance (Typeable a) => GPU (Sampler Tex1D SingleTex (Regular Int) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex2D SingleTex (Regular Int) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex3D SingleTex (Regular Int) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex2D CubeTex (Regular Int) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex1D ArrayTex (Regular Int) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex2D ArrayTex (Regular Int) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex2D SingleTex (MultiSample Int) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex2D ArrayTex (MultiSample Int) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex1D SingleTex (Buffer Int) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler TexRect SingleTex (Regular Int) a) where+ tupleType v = Single $ toType v++-- Word+instance (Typeable a) => GPU (Sampler Tex1D SingleTex (Regular Word) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex2D SingleTex (Regular Word) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex3D SingleTex (Regular Word) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex2D CubeTex (Regular Word) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex1D ArrayTex (Regular Word) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex2D ArrayTex (Regular Word) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex2D SingleTex (MultiSample Word) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex2D ArrayTex (MultiSample Word) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex1D SingleTex (Buffer Word) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler TexRect SingleTex (Regular Word) a) where+ tupleType v = Single $ toType v++-- Shadow+instance (Typeable a) => GPU (Sampler Tex1D SingleTex (Shadow Float) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex2D SingleTex (Shadow Float) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex2D CubeTex (Shadow Float) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex1D ArrayTex (Shadow Float) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler Tex2D ArrayTex (Shadow Float) a) where+ tupleType v = Single $ toType v+instance (Typeable a) => GPU (Sampler TexRect SingleTex (Shadow Float) a) where+ tupleType v = Single $ toType v++instance GPU () where+ tupleType v = Tuple []+instance GPU Bool where+ tupleType v = Single $ toType v+instance GPU Float where+ tupleType v = Single $ toType v+instance GPU Int32 where+ tupleType v = Single $ toType v+instance GPU Word32 where+ tupleType v = Single $ toType v+instance GPU V2B where+ tupleType v = Single $ toType v+instance GPU V2F where+ tupleType v = Single $ toType v+instance GPU V2I where+ tupleType v = Single $ toType v+instance GPU V2U where+ tupleType v = Single $ toType v+instance GPU V3B where+ tupleType v = Single $ toType v+instance GPU V3F where+ tupleType v = Single $ toType v+instance GPU V3I where+ tupleType v = Single $ toType v+instance GPU V3U where+ tupleType v = Single $ toType v+instance GPU V4B where+ tupleType v = Single $ toType v+instance GPU V4F where+ tupleType v = Single $ toType v+instance GPU V4I where+ tupleType v = Single $ toType v+instance GPU V4U where+ tupleType v = Single $ toType v+instance GPU M22F where+ tupleType v = Single $ toType v+instance GPU M23F where+ tupleType v = Single $ toType v+instance GPU M24F where+ tupleType v = Single $ toType v+instance GPU M32F where+ tupleType v = Single $ toType v+instance GPU M33F where+ tupleType v = Single $ toType v+instance GPU M34F where+ tupleType v = Single $ toType v+instance GPU M42F where+ tupleType v = Single $ toType v+instance GPU M43F where+ tupleType v = Single $ toType v+instance GPU M44F where+ tupleType v = Single $ toType v+instance (GPU a, GPU b) => GPU (a, b) where+ tupleType (v :: (a,b)) = Tuple+ [ tupleType (undefined :: a)+ , tupleType (undefined :: b)+ ]+instance (GPU a, GPU b, GPU c) => GPU (a, b, c) where+ tupleType (v :: (a,b,c)) = Tuple+ [ tupleType (undefined :: a)+ , tupleType (undefined :: b)+ , tupleType (undefined :: c)+ ]+instance (GPU a, GPU b, GPU c, GPU d) => GPU (a, b, c, d) where+ tupleType (v :: (a,b,c,d)) = Tuple+ [ tupleType (undefined :: a)+ , tupleType (undefined :: b)+ , tupleType (undefined :: c)+ , tupleType (undefined :: d)+ ]+instance (GPU a, GPU b, GPU c, GPU d, GPU e) => GPU (a, b, c, d, e) where+ tupleType (v :: (a,b,c,d,e)) = Tuple+ [ tupleType (undefined :: a)+ , tupleType (undefined :: b)+ , tupleType (undefined :: c)+ , tupleType (undefined :: d)+ , tupleType (undefined :: e)+ ]+instance (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f) => GPU (a, b, c, d, e, f) where+ tupleType (v :: (a,b,c,d,e,f)) = Tuple+ [ tupleType (undefined :: a)+ , tupleType (undefined :: b)+ , tupleType (undefined :: c)+ , tupleType (undefined :: d)+ , tupleType (undefined :: e)+ , tupleType (undefined :: f)+ ]+instance (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g) => GPU (a, b, c, d, e, f, g) where+ tupleType (v :: (a,b,c,d,e,f,g)) = Tuple+ [ tupleType (undefined :: a)+ , tupleType (undefined :: b)+ , tupleType (undefined :: c)+ , tupleType (undefined :: d)+ , tupleType (undefined :: e)+ , tupleType (undefined :: f)+ , tupleType (undefined :: g)+ ]+instance (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h) => GPU (a, b, c, d, e, f, g, h) where+ tupleType (v :: (a,b,c,d,e,f,g,h)) = Tuple+ [ tupleType (undefined :: a)+ , tupleType (undefined :: b)+ , tupleType (undefined :: c)+ , tupleType (undefined :: d)+ , tupleType (undefined :: e)+ , tupleType (undefined :: f)+ , tupleType (undefined :: g)+ , tupleType (undefined :: h)+ ]+instance (GPU a, GPU b, GPU c, GPU d, GPU e, GPU f, GPU g, GPU h, GPU i) => GPU (a, b, c, d, e, f, g, h, i) where+ tupleType (v :: (a,b,c,d,e,f,g,h,i)) = Tuple+ [ tupleType (undefined :: a)+ , tupleType (undefined :: b)+ , tupleType (undefined :: c)+ , tupleType (undefined :: d)+ , tupleType (undefined :: e)+ , tupleType (undefined :: f)+ , tupleType (undefined :: g)+ , tupleType (undefined :: h)+ , tupleType (undefined :: i)+ ]++-- stream type restriction, these types can be used in vertex shader input+class GPU a => SGPU a+instance SGPU Int32+instance SGPU Word32+instance SGPU Float+instance SGPU M22F+instance SGPU M23F+instance SGPU M24F+instance SGPU M32F+instance SGPU M33F+instance SGPU M34F+instance SGPU M42F+instance SGPU M43F+instance SGPU M44F+instance SGPU V2F+instance SGPU V3F+instance SGPU V4F+instance SGPU V2I+instance SGPU V3I+instance SGPU V4I+instance SGPU V2U+instance SGPU V3U+instance SGPU V4U+instance (SGPU a, SGPU b) => SGPU (a, b)+instance (SGPU a, SGPU b, SGPU c) => SGPU (a, b, c)+instance (SGPU a, SGPU b, SGPU c, SGPU d) => SGPU (a, b, c, d)+instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e) => SGPU (a, b, c, d, e)+instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e, SGPU f) => SGPU (a, b, c, d, e, f)+instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e, SGPU f, SGPU g) => SGPU (a, b, c, d, e, f, g)+instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e, SGPU f, SGPU g, SGPU h) => SGPU (a, b, c, d, e, f, g, h)+instance (SGPU a, SGPU b, SGPU c, SGPU d, SGPU e, SGPU f, SGPU g, SGPU h, SGPU i) => SGPU (a, b, c, d, e, f, g, h, i)++-- uniform type restriction+-- hint: EltRepr stands for Elementary Type Representation+type family EltRepr a :: *+type instance EltRepr (Sampler dim sh t ar) = ((), Sampler dim sh t ar)+type instance EltRepr () = ()+type instance EltRepr Int32 = ((), Int32)+type instance EltRepr Word32 = ((), Word32)+type instance EltRepr Float = ((), Float)+type instance EltRepr Bool = ((), Bool)+type instance EltRepr V2F = ((), V2F)+type instance EltRepr V2I = ((), V2I)+type instance EltRepr V2U = ((), V2U)+type instance EltRepr V2B = ((), V2B)+type instance EltRepr M22F = ((), M22F)+type instance EltRepr M23F = ((), M23F)+type instance EltRepr M24F = ((), M24F)+type instance EltRepr V3F = ((), V3F)+type instance EltRepr V3I = ((), V3I)+type instance EltRepr V3U = ((), V3U)+type instance EltRepr V3B = ((), V3B)+type instance EltRepr M32F = ((), M32F)+type instance EltRepr M33F = ((), M33F)+type instance EltRepr M34F = ((), M34F)+type instance EltRepr V4F = ((), V4F)+type instance EltRepr V4I = ((), V4I)+type instance EltRepr V4U = ((), V4U)+type instance EltRepr V4B = ((), V4B)+type instance EltRepr M42F = ((), M42F)+type instance EltRepr M43F = ((), M43F)+type instance EltRepr M44F = ((), M44F)+type instance EltRepr (a, b) = (EltRepr a, EltRepr' b)+type instance EltRepr (a, b, c) = (EltRepr (a, b), EltRepr' c)+type instance EltRepr (a, b, c, d) = (EltRepr (a, b, c), EltRepr' d)+type instance EltRepr (a, b, c, d, e) = (EltRepr (a, b, c, d), EltRepr' e)+type instance EltRepr (a, b, c, d, e, f) = (EltRepr (a, b, c, d, e), EltRepr' f)+type instance EltRepr (a, b, c, d, e, f, g) = (EltRepr (a, b, c, d, e, f), EltRepr' g)+type instance EltRepr (a, b, c, d, e, f, g, h) = (EltRepr (a, b, c, d, e, f, g), EltRepr' h)+type instance EltRepr (a, b, c, d, e, f, g, h, i) = (EltRepr (a, b, c, d, e, f, g, h), EltRepr' i)++type family EltRepr' a :: *+type instance EltRepr' (Sampler dim sh t ar) = Sampler dim sh t ar+type instance EltRepr' () = ()+type instance EltRepr' Int32 = Int32+type instance EltRepr' Word32 = Word32+type instance EltRepr' Float = Float+type instance EltRepr' Bool = Bool+type instance EltRepr' V2F = V2F+type instance EltRepr' V2I = V2I+type instance EltRepr' V2U = V2U+type instance EltRepr' V2B = V2B+type instance EltRepr' M22F = M22F+type instance EltRepr' M23F = M23F+type instance EltRepr' M24F = M24F+type instance EltRepr' V3F = V3F+type instance EltRepr' V3I = V3I+type instance EltRepr' V3U = V3U+type instance EltRepr' V3B = V3B+type instance EltRepr' M32F = M32F+type instance EltRepr' M33F = M33F+type instance EltRepr' M34F = M34F+type instance EltRepr' V4F = V4F+type instance EltRepr' V4I = V4I+type instance EltRepr' V4U = V4U+type instance EltRepr' V4B = V4B+type instance EltRepr' M42F = M42F+type instance EltRepr' M43F = M43F+type instance EltRepr' M44F = M44F+type instance EltRepr' (a, b) = (EltRepr a, EltRepr' b)+type instance EltRepr' (a, b, c) = (EltRepr (a, b), EltRepr' c)+type instance EltRepr' (a, b, c, d) = (EltRepr (a, b, c), EltRepr' d)+type instance EltRepr' (a, b, c, d, e) = (EltRepr (a, b, c, d), EltRepr' e)+type instance EltRepr' (a, b, c, d, e, f) = (EltRepr (a, b, c, d, e), EltRepr' f)+type instance EltRepr' (a, b, c, d, e, f, g) = (EltRepr (a, b, c, d, e, f), EltRepr' g)+type instance EltRepr' (a, b, c, d, e, f, g, h) = (EltRepr (a, b, c, d, e, f, g), EltRepr' h)+type instance EltRepr' (a, b, c, d, e, f, g, h, i) = (EltRepr (a, b, c, d, e, f, g, h), EltRepr' i)++-- |Conversion between surface n-tuples and our tuple representation.+--+-- our language uses nested tuple representation+class IsTuple tup where+ type TupleRepr tup++instance IsTuple () where+ type TupleRepr () = ()+ +instance IsTuple (a, b) where+ type TupleRepr (a, b) = (((), a), b)+ +instance IsTuple (a, b, c) where+ type TupleRepr (a, b, c) = (TupleRepr (a, b), c)++instance IsTuple (a, b, c, d) where+ type TupleRepr (a, b, c, d) = (TupleRepr (a, b, c), d)++instance IsTuple (a, b, c, d, e) where+ type TupleRepr (a, b, c, d, e) = (TupleRepr (a, b, c, d), e)++instance IsTuple (a, b, c, d, e, f) where+ type TupleRepr (a, b, c, d, e, f) = (TupleRepr (a, b, c, d, e), f)++instance IsTuple (a, b, c, d, e, f, g) where+ type TupleRepr (a, b, c, d, e, f, g) = (TupleRepr (a, b, c, d, e, f), g)++instance IsTuple (a, b, c, d, e, f, g, h) where+ type TupleRepr (a, b, c, d, e, f, g, h) = (TupleRepr (a, b, c, d, e, f, g), h)++instance IsTuple (a, b, c, d, e, f, g, h, i) where+ type TupleRepr (a, b, c, d, e, f, g, h, i) = (TupleRepr (a, b, c, d, e, f, g, h), i)++-- Tuple representation+-- --------------------++-- |We represent tuples as heterogenous lists, typed by a type list.+--+data Tuple c t where+ NilTup :: Tuple c ()+ SnocTup :: GPU t => Tuple c s -> c t -> Tuple c (s, t)++-- |Type-safe projection indicies for tuples.+--+-- NB: We index tuples by starting to count from the *right*!+--+data TupleIdx t e where+ ZeroTupIdx :: GPU s => TupleIdx (t, s) s+ SuccTupIdx :: TupleIdx t e -> TupleIdx (t, s) e++-- Auxiliary tuple index constants+--+tix0 :: GPU s => TupleIdx (t, s) s+tix0 = ZeroTupIdx+tix1 :: GPU s => TupleIdx ((t, s), s1) s+tix1 = SuccTupIdx tix0+tix2 :: GPU s => TupleIdx (((t, s), s1), s2) s+tix2 = SuccTupIdx tix1+tix3 :: GPU s => TupleIdx ((((t, s), s1), s2), s3) s+tix3 = SuccTupIdx tix2+tix4 :: GPU s => TupleIdx (((((t, s), s1), s2), s3), s4) s+tix4 = SuccTupIdx tix3+tix5 :: GPU s => TupleIdx ((((((t, s), s1), s2), s3), s4), s5) s+tix5 = SuccTupIdx tix4+tix6 :: GPU s => TupleIdx (((((((t, s), s1), s2), s3), s4), s5), s6) s+tix6 = SuccTupIdx tix5+tix7 :: GPU s => TupleIdx ((((((((t, s), s1), s2), s3), s4), s5), s6), s7) s+tix7 = SuccTupIdx tix6+tix8 :: GPU s => TupleIdx (((((((((t, s), s1), s2), s3), s4), s5), s6), s7), s8) s+tix8 = SuccTupIdx tix7++deriving instance Typeable (,,,,,,,)+deriving instance Typeable (,,,,,,,,)
+ src/lib/LambdaCube/Language/Sampler.hs view
@@ -0,0 +1,263 @@+module LambdaCube.Language.Sampler where++import Data.Int++import LambdaCube.Core.Type+import LambdaCube.Language.ReifyType++{-+-- shadow samplers+type Sampler1DShadow = Sampler DIM1 Z Depth Mip Shadow+type Sampler2DShadow = Sampler DIM2 Z Depth Mip Shadow+type SamplerCubeShadow = Sampler DIM2 C Depth Mip Array Shadow+type Sampler1DArrayShadow = Sampler DIM1 A Depth Mip Array Shadow+type Sampler2DArrayShadow = Sampler DIM2 A Depth Mip Array Shadow+type Sampler2DRectShadow = Sampler Rect Z Depth NoMip Shadow++-- float,int,word samplers+type Sampler1D = Sampler DIM1 Z Float Mip Regular+type Sampler2D = Sampler DIM2 Z Float Mip Regular+type Sampler3D = Sampler DIM3 Z Float Mip Regular+type SamplerCube = Sampler DIM2 C Float Mip Regular Array+type Sampler1DArray = Sampler DIM1 A Float Mip Regular Array+type Sampler2DArray = Sampler DIM2 A Float Mip Regular Array+type Sampler2DRect = Sampler Rect Z Float NoMip Regular++type Sampler2DMS = Sampler DIM2 Z FloatMS NoMip -- from previous render pass only+type Sampler2DMSArray = Sampler DIM2 A FloatMS NoMip Array -- from previous render pass only+type SamplerBuffer = Sampler DIM1 Z BufferFloat NoMip+-}++type GSampler1D t ar = Sampler Tex1D SingleTex t ar+type GSampler2D t ar = Sampler Tex2D SingleTex t ar+type GSampler3D t ar = Sampler Tex3D SingleTex t ar+type GSamplerCube t ar = Sampler Tex2D CubeTex t ar+type GSampler1DArray t ar = Sampler Tex1D ArrayTex t ar+type GSampler2DArray t ar = Sampler Tex2D ArrayTex t ar+type GSampler2DRect t ar = Sampler TexRect SingleTex t ar++type family TexelRepr sampler+type instance TexelRepr (Sampler dim arr (v t) Red) = t+type instance TexelRepr (Sampler dim arr (v t) RG) = V2 t+type instance TexelRepr (Sampler dim arr (v t) RGB) = V3 t+type instance TexelRepr (Sampler dim arr (v t) RGBA) = V4 t++-- shadow samplers+type Sampler1DShadow = GSampler1D (Shadow Float) Red+type Sampler2DShadow = GSampler2D (Shadow Float) Red+type SamplerCubeShadow = GSamplerCube (Shadow Float) Red+type Sampler1DArrayShadow = GSampler1DArray (Shadow Float) Red+type Sampler2DArrayShadow = GSampler2DArray (Shadow Float) Red+type Sampler2DRectShadow = GSampler2DRect (Shadow Float) Red++-- float samplers+type Sampler1D t ar = GSampler1D (Regular t) ar+type Sampler2D t ar = GSampler2D (Regular t) ar+type Sampler3D t ar = GSampler3D (Regular t) ar+type SamplerCube t ar = GSamplerCube (Regular t) ar+type Sampler1DArray t ar = GSampler1DArray (Regular t) ar+type Sampler2DArray t ar = GSampler2DArray (Regular t) ar+type Sampler2DRect t ar = GSampler2DRect (Regular t) ar+type Sampler2DMS t ar = GSampler2D (MultiSample t) ar+type Sampler2DMSArray t ar = GSampler2DArray (MultiSample t) ar+type SamplerBuffer t ar = GSampler1D (Buffer t) ar++-- brute force+-- arity problem: lod+-- restriction: NONE+class IsTextureSize sampler lod size | sampler -> lod size+instance IsTextureSize (Sampler1D t ar) Int32 Int32+instance IsTextureSize (Sampler1DArray t ar) Int32 V2I+instance IsTextureSize (Sampler2D t ar) Int32 V2I+instance IsTextureSize (Sampler2DArray t ar) Int32 V3I+instance IsTextureSize (Sampler2DMS t ar) () V2I+instance IsTextureSize (Sampler2DMSArray t ar) () V3I+instance IsTextureSize (Sampler2DRect t ar) () V2I+instance IsTextureSize (Sampler3D t ar) Int32 V3I+instance IsTextureSize (SamplerCube t ar) Int32 V2I+instance IsTextureSize (SamplerBuffer t ar) () Int32+instance IsTextureSize Sampler1DArrayShadow Int32 V2I+instance IsTextureSize Sampler1DShadow Int32 Int32+instance IsTextureSize Sampler2DArrayShadow Int32 V3I+instance IsTextureSize Sampler2DRectShadow () V2I+instance IsTextureSize Sampler2DShadow Int32 V2I+instance IsTextureSize SamplerCubeShadow Int32 V2I++-- arity problem: bias+-- restriction: Regular union Shadow+class IsTexture sampler coord bias | sampler -> coord bias+instance IsTexture (Sampler1D t ar) Float Float+instance IsTexture (Sampler1DArray t ar) V2F Float+instance IsTexture (Sampler2D t ar) V2F Float+instance IsTexture (Sampler2DArray t ar) V3F Float+instance IsTexture (Sampler2DRect t ar) V2F () +instance IsTexture (Sampler3D t ar) V3F Float+instance IsTexture (SamplerCube t ar) V3F Float+instance IsTexture Sampler1DShadow V3F Float+instance IsTexture Sampler1DArrayShadow V3F Float+instance IsTexture Sampler2DShadow V3F Float+instance IsTexture Sampler2DArrayShadow V4F () +instance IsTexture Sampler2DRectShadow V3F () +instance IsTexture SamplerCubeShadow V4F Float++-- arity problem: bias+-- restriction: (Regular union Shadow) exclude Array+class IsTextureProj sampler coord bias | sampler coord -> bias+instance IsTextureProj (Sampler1D t ar) V2F Float+instance IsTextureProj (Sampler1D t ar) V4F Float+instance IsTextureProj (Sampler2D t ar) V3F Float+instance IsTextureProj (Sampler2D t ar) V4F Float+instance IsTextureProj (Sampler2DRect t ar) V3F () +instance IsTextureProj (Sampler2DRect t ar) V4F () +instance IsTextureProj (Sampler3D t ar) V4F Float+instance IsTextureProj Sampler1DShadow V4F Float+instance IsTextureProj Sampler2DRectShadow V4F () +instance IsTextureProj Sampler2DShadow V4F Float++-- arity ok+-- restriction: ((Regular union Shadow) intersection Mip) exclude (2D Shadow Array)+class IsTextureLod sampler coord lod | sampler -> coord lod+instance IsTextureLod (Sampler1D t ar) Float Float+instance IsTextureLod (Sampler1DArray t ar) V2F Float+instance IsTextureLod (Sampler2D t ar) V2F Float+instance IsTextureLod (Sampler2DArray t ar) V3F Float+instance IsTextureLod (Sampler3D t ar) V3F Float+instance IsTextureLod (SamplerCube t ar) V3F Float+instance IsTextureLod Sampler1DShadow V3F Float+instance IsTextureLod Sampler1DArrayShadow V3F Float+instance IsTextureLod Sampler2DShadow V3F Float++-- arity problem: bias+-- restriction: (Regular union Shadow) excluding (Cube, 2D Shadow Array)+class IsTextureOffset sampler coord offset bias | sampler -> coord offset bias+instance IsTextureOffset (Sampler1D t ar) Float Int32 Float+instance IsTextureOffset (Sampler1DArray t ar) V2F Int32 Float+instance IsTextureOffset (Sampler2D t ar) V2F V2I Float+instance IsTextureOffset (Sampler2DArray t ar) V3F V2I Float+instance IsTextureOffset (Sampler2DRect t ar) V2F V2I () +instance IsTextureOffset (Sampler3D t ar) V3F V3I Float+instance IsTextureOffset Sampler1DShadow V3F Int32 Float+instance IsTextureOffset Sampler1DArrayShadow V3F Int32 Float+instance IsTextureOffset Sampler2DShadow V3F V2I Float+instance IsTextureOffset Sampler2DRectShadow V3F V2I () ++-- arity problem: lod, sample+class IsTexelFetch sampler coord lod | sampler -> coord lod+instance IsTexelFetch (Sampler1D t ar) Int32 Int32+instance IsTexelFetch (Sampler1DArray t ar) V2I Int32+instance IsTexelFetch (Sampler2D t ar) V2I Int32+instance IsTexelFetch (Sampler2DArray t ar) V3I Int32+instance IsTexelFetch (Sampler2DMS t ar) V2I Int32+instance IsTexelFetch (Sampler2DMSArray t ar) V3I Int32+instance IsTexelFetch (Sampler2DRect t ar) V2I () +instance IsTexelFetch (Sampler3D t ar) V3I Int32+instance IsTexelFetch (SamplerBuffer t ar) Int32 () ++-- arity problem: lod+class IsTexelFetchOffset sampler coord lod offset | sampler -> coord lod offset+instance IsTexelFetchOffset (Sampler1D t ar) Int32 Int32 Int32+instance IsTexelFetchOffset (Sampler1DArray t ar) V2I Int32 Int32+instance IsTexelFetchOffset (Sampler2D t ar) V2I Int32 V2I +instance IsTexelFetchOffset (Sampler2DArray t ar) V3I Int32 V2I +instance IsTexelFetchOffset (Sampler2DRect t ar) V2I () V2I +instance IsTexelFetchOffset (Sampler3D t ar) V3I Int32 V3I ++-- arity problem: bias+class IsTextureProjOffset sampler coord offset bias | sampler coord -> offset bias+instance IsTextureProjOffset (Sampler1D t ar) V2F Int32 Float+instance IsTextureProjOffset (Sampler1D t ar) V4F Int32 Float+instance IsTextureProjOffset (Sampler2D t ar) V3F V2I Float+instance IsTextureProjOffset (Sampler2D t ar) V4F V2I Float+instance IsTextureProjOffset (Sampler3D t ar) V4F V3I Float+instance IsTextureProjOffset (Sampler2DRect t ar) V3F V2I () +instance IsTextureProjOffset (Sampler2DRect t ar) V4F V2I () +instance IsTextureProjOffset Sampler1DShadow V4F Int32 Float+instance IsTextureProjOffset Sampler2DShadow V4F V2I Float+instance IsTextureProjOffset Sampler2DRectShadow V4F V2I Float++-- arity ok+class IsTextureLodOffset sampler coord lod offset | sampler -> coord lod offset+instance IsTextureLodOffset (Sampler1D t ar) Float Float Int32+instance IsTextureLodOffset (Sampler1DArray t ar) V2F Float Int32+instance IsTextureLodOffset (Sampler2D t ar) V2F Float V2I +instance IsTextureLodOffset (Sampler2DArray t ar) V3F Float V2I +instance IsTextureLodOffset (Sampler3D t ar) V3F Float V3I +instance IsTextureLodOffset Sampler1DShadow V3F Float Int32+instance IsTextureLodOffset Sampler1DArrayShadow V3F Float Int32+instance IsTextureLodOffset Sampler2DShadow V3F Float V2I ++-- arity ok+class IsTextureProjLod sampler coord lod | sampler coord -> lod+instance IsTextureProjLod (Sampler1D t ar) V2F Float+instance IsTextureProjLod (Sampler1D t ar) V4F Float+instance IsTextureProjLod (Sampler2D t ar) V3F Float+instance IsTextureProjLod (Sampler2D t ar) V4F Float+instance IsTextureProjLod (Sampler3D t ar) V4F Float+instance IsTextureProjLod Sampler1DShadow V4F Float+instance IsTextureProjLod Sampler2DShadow V4F Float++-- arity ok+class IsTextureProjLodOffset sampler coord lod offset | sampler coord -> lod offset+instance IsTextureProjLodOffset (Sampler1D t ar) V2F Float Int32+instance IsTextureProjLodOffset (Sampler1D t ar) V4F Float Int32+instance IsTextureProjLodOffset (Sampler2D t ar) V3F Float V2I +instance IsTextureProjLodOffset (Sampler2D t ar) V4F Float V2I +instance IsTextureProjLodOffset (Sampler3D t ar) V4F Float V3I +instance IsTextureProjLodOffset Sampler1DShadow V4F Float Int32+instance IsTextureProjLodOffset Sampler2DShadow V4F Float V2F ++-- arity ok+class IsTextureGrad sampler coord dx dy | sampler -> coord dx dy+instance IsTextureGrad (Sampler1D t ar) Float Float Float+instance IsTextureGrad (Sampler1DArray t ar) V2F Float Float+instance IsTextureGrad (Sampler2D t ar) V2F V2F V2F +instance IsTextureGrad (Sampler2DArray t ar) V3F V2F V2F +instance IsTextureGrad (Sampler2DRect t ar) V2F V2F V2F +instance IsTextureGrad (Sampler3D t ar) V3F V3F V3F +instance IsTextureGrad (SamplerCube t ar) V3F V3F V3F +instance IsTextureGrad Sampler1DArrayShadow V3F Float Float+instance IsTextureGrad Sampler1DShadow V3F Float Float+instance IsTextureGrad Sampler2DArrayShadow V4F V2F V2F +instance IsTextureGrad Sampler2DRectShadow V3F V2F V2F +instance IsTextureGrad Sampler2DShadow V3F V2F V2F +instance IsTextureGrad SamplerCubeShadow V4F V3F V3F ++-- arity ok+class IsTextureGradOffset sampler coord dx dy offset | sampler -> coord dx dy offset+instance IsTextureGradOffset (Sampler1D t ar) Float Float Float Int32+instance IsTextureGradOffset (Sampler1DArray t ar) V2F Float Float Int32+instance IsTextureGradOffset (Sampler2D t ar) V2F V2F V2F V2I +instance IsTextureGradOffset (Sampler2DArray t ar) V3F V2F V2F V2I +instance IsTextureGradOffset (Sampler2DRect t ar) V2F V2F V2F V2I +instance IsTextureGradOffset (Sampler3D t ar) V3F V3F V3F V3I +instance IsTextureGradOffset Sampler1DArrayShadow V3F Float Float Int32+instance IsTextureGradOffset Sampler1DShadow V3F Float Float Int32+instance IsTextureGradOffset Sampler2DArrayShadow V4F V2F V2F V2I +instance IsTextureGradOffset Sampler2DRectShadow V3F V2F V2F V2I +instance IsTextureGradOffset Sampler2DShadow V3F V2F V2F V2I ++-- arity ok+class IsTextureProjGrad sampler coord dx dy | sampler coord -> dx dy+instance IsTextureProjGrad (Sampler1D t ar) V2F Float Float+instance IsTextureProjGrad (Sampler1D t ar) V4F Float Float+instance IsTextureProjGrad (Sampler2D t ar) V3F V2F V2F +instance IsTextureProjGrad (Sampler2D t ar) V4F V2F V2F +instance IsTextureProjGrad (Sampler2DRect t ar) V3F V2F V2F +instance IsTextureProjGrad (Sampler2DRect t ar) V4F V2F V2F +instance IsTextureProjGrad (Sampler3D t ar) V4F V3F V3F +instance IsTextureProjGrad Sampler1DShadow V4F Float Float+instance IsTextureProjGrad Sampler2DRectShadow V4F V2F V2F +instance IsTextureProjGrad Sampler2DShadow V4F V2F V2F ++-- arity ok+class IsTextureProjGradOffset sampler coord dx dy offset | sampler coord -> dx dy offset+instance IsTextureProjGradOffset (Sampler1D t ar) V2F Float Float Int32+instance IsTextureProjGradOffset (Sampler1D t ar) V4F Float Float Int32+instance IsTextureProjGradOffset (Sampler2D t ar) V3F V2F V2F V2I +instance IsTextureProjGradOffset (Sampler2D t ar) V4F V2F V2F V2I +instance IsTextureProjGradOffset (Sampler2DRect t ar) V3F V2F V2F V2I +instance IsTextureProjGradOffset (Sampler2DRect t ar) V4F V2F V2F V2I +instance IsTextureProjGradOffset (Sampler3D t ar) V4F V3F V3F V3I +instance IsTextureProjGradOffset Sampler1DShadow V4F Float Float Int32+instance IsTextureProjGradOffset Sampler2DRectShadow V4F V2F V2F V2I +instance IsTextureProjGradOffset Sampler2DShadow V4F V2F V2F V2I
+ src/lib/LambdaCube/Language/Type.hs view
@@ -0,0 +1,687 @@+module LambdaCube.Language.Type where++import GHC.TypeLits++import Data.ByteString.Char8+import Data.Int+import Data.Word+import Data.Typeable++import qualified LambdaCube.Core.Type as U+import LambdaCube.Core.Type hiding (FetchPrimitive, OutputPrimitive, Blending, RasterContext, Blend, TriangleCtx, Image, FragmentOperation, MipMap, TextureDataType, TextureType)+import LambdaCube.Language.ReifyType hiding (Shadow)+import qualified LambdaCube.Language.ReifyType as T++data NatNum :: Nat -> * where+ N0 :: NatNum 0+ N1 :: NatNum 1+ N2 :: NatNum 2+ N3 :: NatNum 3+ N4 :: NatNum 4+ N5 :: NatNum 5+ N6 :: NatNum 6+ N7 :: NatNum 7+ N8 :: NatNum 8+ N9 :: NatNum 9++deriving instance Typeable NatNum++n0 = N0+n1 = N1+n2 = N2+n3 = N3+n4 = N4+n5 = N5+n6 = N6+n7 = N7+n8 = N8+n9 = N9++-- user can define stream input using InputTuple type class+class InputTuple tup where+ type InputTupleRepr tup+ toInputList :: tup -> [(ByteString,InputType)]++instance InputTuple (Input a) where+ type InputTupleRepr (Input a) = a+ toInputList a = [toInput a]++instance InputTuple (Input a, Input b) where+ type InputTupleRepr (Input a, Input b) = (a, b)+ toInputList (a, b) = [toInput a, toInput b]++instance InputTuple (Input a, Input b, Input c) where+ type InputTupleRepr (Input a, Input b, Input c) = (a, b, c)+ toInputList (a, b, c) = [toInput a, toInput b, toInput c]++instance InputTuple (Input a, Input b, Input c, Input d) where+ type InputTupleRepr (Input a, Input b, Input c, Input d) = (a, b, c, d)+ toInputList (a, b, c, d) = [toInput a, toInput b, toInput c, toInput d]++instance InputTuple (Input a, Input b, Input c, Input d, Input e) where+ type InputTupleRepr (Input a, Input b, Input c, Input d, Input e) = (a, b, c, d, e)+ toInputList (a, b, c, d, e) = [toInput a, toInput b, toInput c, toInput d, toInput e]++instance InputTuple (Input a, Input b, Input c, Input d, Input e, Input f) where+ type InputTupleRepr (Input a, Input b, Input c, Input d, Input e, Input f) = (a, b, c, d, e, f)+ toInputList (a, b, c, d, e, f) = [toInput a, toInput b, toInput c, toInput d, toInput e, toInput f]++instance InputTuple (Input a, Input b, Input c, Input d, Input e, Input f, Input g) where+ type InputTupleRepr (Input a, Input b, Input c, Input d, Input e, Input f, Input g) = (a, b, c, d, e, f, g)+ toInputList (a, b, c, d, e, f, g) = [toInput a, toInput b, toInput c, toInput d, toInput e, toInput f, toInput g]++instance InputTuple (Input a, Input b, Input c, Input d, Input e, Input f, Input g, Input h) where+ type InputTupleRepr (Input a, Input b, Input c, Input d, Input e, Input f, Input g, Input h) = (a, b, c, d, e, f, g, h)+ toInputList (a, b, c, d, e, f, g, h) = [toInput a, toInput b, toInput c, toInput d, toInput e, toInput f, toInput g, toInput h]++instance InputTuple (Input a, Input b, Input c, Input d, Input e, Input f, Input g, Input h, Input i) where+ type InputTupleRepr (Input a, Input b, Input c, Input d, Input e, Input f, Input g, Input h, Input i) = (a, b, c, d, e, f, g, h, i)+ toInputList (a, b, c, d, e, f, g, h, i) = [toInput a, toInput b, toInput c, toInput d, toInput e, toInput f, toInput g, toInput h, toInput i]++-- we should define all of input types+-- supported stream input types (the ByteString argument is the input slot name)+data Input a where+ IBool :: ByteString -> Input Bool+ IV2B :: ByteString -> Input V2B+ IV3B :: ByteString -> Input V3B+ IV4B :: ByteString -> Input V4B+ IWord :: ByteString -> Input Word32+ IV2U :: ByteString -> Input V2U+ IV3U :: ByteString -> Input V3U+ IV4U :: ByteString -> Input V4U+ IInt :: ByteString -> Input Int32+ IV2I :: ByteString -> Input V2I+ IV3I :: ByteString -> Input V3I+ IV4I :: ByteString -> Input V4I+ IFloat :: ByteString -> Input Float+ IV2F :: ByteString -> Input V2F+ IV3F :: ByteString -> Input V3F+ IV4F :: ByteString -> Input V4F+ IM22F :: ByteString -> Input M22F+ IM23F :: ByteString -> Input M23F+ IM24F :: ByteString -> Input M24F+ IM32F :: ByteString -> Input M32F+ IM33F :: ByteString -> Input M33F+ IM34F :: ByteString -> Input M34F+ IM42F :: ByteString -> Input M42F+ IM43F :: ByteString -> Input M43F+ IM44F :: ByteString -> Input M44F++toInput :: Input a -> (ByteString,InputType)+toInput (IBool n) = (n, U.Bool)+toInput (IV2B n) = (n, U.V2B)+toInput (IV3B n) = (n, U.V3B)+toInput (IV4B n) = (n, U.V4B)+toInput (IWord n) = (n, U.Word)+toInput (IV2U n) = (n, U.V2U)+toInput (IV3U n) = (n, U.V3U)+toInput (IV4U n) = (n, U.V4U)+toInput (IInt n) = (n, U.Int)+toInput (IV2I n) = (n, U.V2I)+toInput (IV3I n) = (n, U.V3I)+toInput (IV4I n) = (n, U.V4I)+toInput (IFloat n) = (n, U.Float)+toInput (IV2F n) = (n, U.V2F)+toInput (IV3F n) = (n, U.V3F)+toInput (IV4F n) = (n, U.V4F)+toInput (IM22F n) = (n, U.M22F)+toInput (IM23F n) = (n, U.M23F)+toInput (IM24F n) = (n, U.M24F)+toInput (IM32F n) = (n, U.M32F)+toInput (IM33F n) = (n, U.M33F)+toInput (IM34F n) = (n, U.M34F)+toInput (IM42F n) = (n, U.M42F)+toInput (IM43F n) = (n, U.M43F)+toInput (IM44F n) = (n, U.M44F)++-- primitive types+data PrimitiveType+ = Triangle+ | Line+ | Point+ | TriangleAdjacency+ | LineAdjacency++data FetchPrimitive :: PrimitiveType -> * where+ Points :: FetchPrimitive Point+ Lines :: FetchPrimitive Line+ Triangles :: FetchPrimitive Triangle+ LinesAdjacency :: FetchPrimitive LineAdjacency+ TrianglesAdjacency :: FetchPrimitive TriangleAdjacency++data OutputPrimitive :: PrimitiveType -> * where+ TrianglesOutput :: OutputPrimitive Triangle+ LinesOutput :: OutputPrimitive Line+ PointsOutput :: OutputPrimitive Point++data Blending c where+ NoBlending :: Blending c++ BlendLogicOp :: IsIntegral c+ => LogicOperation+ -> Blending c++ -- FIXME: restrict BlendingFactor at some BlendEquation+ Blend :: (BlendEquation, BlendEquation) + -> ((BlendingFactor, BlendingFactor), (BlendingFactor, BlendingFactor))+ -> V4F+ -> Blending Float++blend = Blend (FuncAdd,FuncAdd) ((SrcAlpha,OneMinusSrcAlpha),(SrcAlpha,OneMinusSrcAlpha)) (V4 1 1 1 1)++-- abstract types, used in language AST+data VertexStream (primitive :: PrimitiveType) t+data PrimitiveStream (primitive :: PrimitiveType) clipDistances (layerCount :: Nat) (freq :: Frequency) t+data FragmentStream (layerCount :: Nat) t+++-- flat tuple, another internal tuple representation++-- means unit+data ZZ = ZZ deriving (Show,Typeable)++-- used for tuple type description+infixr 1 :+:+data tail :+: head = !tail :+: !head deriving (Show,Typeable)++-- used for tuple value description+infixr 1 :.+data FlatTuple c a t where+ ZT :: FlatTuple c a ZZ++ (:.) :: c t+ => a t+ -> FlatTuple c a t'+ -> FlatTuple c a (t :+: t')++class IsFloatTuple a+instance IsFloatTuple ZZ+instance IsFloatTuple l => IsFloatTuple (Float :+: l)++-- vertex attribute interpolation+data Interpolated e a where+ Flat :: e a -> Interpolated e a++ Smooth :: IsFloating a+ => e a -> Interpolated e a++ NoPerspective :: IsFloating a+ => e a -> Interpolated e a++-- framebuffer data / fragment output semantic+data Color a+data Depth a+data Stencil a++-- describe geometry shader input +type family PrimitiveVertices (primitive :: PrimitiveType) a+type instance PrimitiveVertices Point a = a+type instance PrimitiveVertices Line a = (a,a)+type instance PrimitiveVertices LineAdjacency a = (a,a,a,a)+type instance PrimitiveVertices Triangle a = (a,a,a)+type instance PrimitiveVertices TriangleAdjacency a = (a,a,a,a,a,a)++-- raster context description+data RasterContext t where+ PointCtx ::+ { ctxPointSize :: PointSize+ , ctxFadeThresholdSize :: Float+ , ctxSpriteCoordOrigin :: PointSpriteCoordOrigin+ } -> RasterContext Point++ LineCtx :: + { ctxLineWidth :: Float+ , ctxProvokingVertex' :: ProvokingVertex+ } -> RasterContext Line++ TriangleCtx ::+ { ctxCullMode :: CullMode+ , ctxPolygonMode :: PolygonMode+ , ctxPolygonOffset :: PolygonOffset+ , ctxProvokingVertex :: ProvokingVertex+ } -> RasterContext Triangle++-- default triangle raster context+triangleCtx :: RasterContext Triangle+triangleCtx = TriangleCtx CullNone PolygonFill NoOffset LastVertex++class NoConstraint a+instance NoConstraint a++type FrameBuffer layerCount t = FlatTuple NoConstraint (Image layerCount) t++-- Fragment Operation+data FragmentOperation ty where+ DepthOp :: DepthFunction+ -> Bool -- depth write+ -> FragmentOperation (Depth Float)++ StencilOp :: StencilTests+ -> StencilOps+ -> StencilOps+ -> FragmentOperation (Stencil Int32)++ ColorOp :: (IsVecScalar d mask Bool, IsVecScalar d color c, IsNum c, IsScalar mask)+ => Blending c -- blending type+ -> mask -- write mask+ -> FragmentOperation (Color color)++-- specifies an empty image (pixel rectangle)+-- hint: framebuffer is composed from images+data Image (layerCount :: Nat) t where+ DepthImage :: KnownNat layerCount+ => NatNum layerCount+ -> Float -- initial value+ -> Image layerCount (Depth Float)++ StencilImage :: KnownNat layerCount+ => NatNum layerCount+ -> Int32 -- initial value+ -> Image layerCount (Stencil Int32)++ ColorImage :: (IsNum t, IsVecScalar d color t, IsScalar color, KnownNat layerCount)+ => NatNum layerCount+ -> color -- initial value+ -> Image layerCount (Color color)+ + UnclearedImage :: (IsNum t, IsVecScalar d color t, IsScalar color, KnownNat layerCount)+ => NatNum layerCount+ -> Image layerCount (Color color)+ +++-- restriction for framebuffer structure according content semantic+-- supported configurations: optional stencil + optional depth + [zero or more color]+class IsColorOutput a+instance IsColorOutput ZZ+instance (IsColorOutput b) => IsColorOutput (Color c :+: b)++class IsValidOutput a+instance (IsColorOutput a) => IsValidOutput (Color c :+: a)+instance (IsColorOutput a) => IsValidOutput (Depth d :+: a)+instance (IsColorOutput a) => IsValidOutput (Stencil s :+: a)+instance (IsColorOutput a) => IsValidOutput (Stencil s :+: Depth d :+: a)++-- helper class (type level function), used in language AST+-- converts FlatTuple type to ordinary tuple type+type family FTRepr a :: *+type instance FTRepr ZZ = ()+type instance FTRepr (a :+: ZZ) = a+type instance FTRepr (a :+: b :+: ZZ) = (a, b)+type instance FTRepr (a :+: b :+: c :+: ZZ) = (a, b, c)+type instance FTRepr (a :+: b :+: c :+: d :+: ZZ) = (a, b, c, d)+type instance FTRepr (a :+: b :+: c :+: d :+: e :+: ZZ) = (a, b, c, d, e)+type instance FTRepr (a :+: b :+: c :+: d :+: e :+: f :+: ZZ) = (a, b, c, d, e, f)+type instance FTRepr (a :+: b :+: c :+: d :+: e :+: f :+: g :+: ZZ) = (a, b, c, d, e, f, g)+type instance FTRepr (a :+: b :+: c :+: d :+: e :+: f :+: g :+: h :+: ZZ) = (a, b, c, d, e, f, g, h)+type instance FTRepr (a :+: b :+: c :+: d :+: e :+: f :+: g :+: h :+: i :+: ZZ) = (a, b, c, d, e, f, g, h, i)++-- helper type level function, used in language AST+type family FTRepr' a :: *+type instance FTRepr' (i1 a :+: ZZ) = a+type instance FTRepr' (i1 a :+: i2 b :+: ZZ) = (a, b)+type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: ZZ) = (a, b, c)+type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: ZZ) = (a, b, c, d)+type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: ZZ) = (a, b, c, d, e)+type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: i6 f :+: ZZ) = (a, b, c, d, e, f)+type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: i6 f :+: i7 g :+: ZZ) = (a, b, c, d, e, f, g)+type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: i6 f :+: i7 g :+: i8 h :+: ZZ) = (a, b, c, d, e, f, g, h)+type instance FTRepr' (i1 a :+: i2 b :+: i3 c :+: i4 d :+: i5 e :+: i6 f :+: i7 g :+: i8 h :+: i9 i :+: ZZ) = (a, b, c, d, e, f, g, h ,i)++-- helper type level function, used in language AST+type family ColorRepr a :: *+type instance ColorRepr ZZ = ZZ+type instance ColorRepr (a :+: b) = Color a :+: (ColorRepr b)++-- helper type level function, used in language AST+type family NoStencilRepr a :: *+type instance NoStencilRepr ZZ = ZZ+type instance NoStencilRepr (Stencil a :+: b) = NoStencilRepr b+type instance NoStencilRepr (Color a :+: b) = Color a :+: (NoStencilRepr b)+type instance NoStencilRepr (Depth a :+: b) = Depth a :+: (NoStencilRepr b)++-- sampler and texture specification+data TextureMipMap+ = TexMip+ | TexNoMip++deriving instance Typeable TexMip+deriving instance Typeable TexNoMip++deriving instance Typeable MipMap+++data MipMap (t :: TextureMipMap) where+ NoMip :: MipMap TexNoMip++ Mip :: Int -- base level+ -> Int -- max level+ -> MipMap TexMip++ AutoMip :: Int -- base level+ -> Int -- max level+ -> MipMap TexMip++-- helper type level function, used in language AST+type family TexDataRepr arity (t :: TextureSemantics *)+type instance TexDataRepr Red (v a) = a+type instance TexDataRepr RG (v a) = V2 a+type instance TexDataRepr RGB (v a) = V3 a+type instance TexDataRepr RGBA (v a) = V4 a++-- describes texel (texture component) type+data TextureDataType (kind :: TextureSemantics *) arity where+ Float :: IsColorArity a+ => a+ -> TextureDataType (Regular Float) a++ Int :: IsColorArity a+ => a+ -> TextureDataType (Regular Int) a++ Word :: IsColorArity a+ => a+ -> TextureDataType (Regular Word) a++ Shadow :: TextureDataType (T.Shadow Float) Red -- TODO: add params required by shadow textures+++-- helper type level function for texture specification+-- tells whether a texture is a single or an array texture+type family TexArrRepr (a :: Nat) :: TextureArray+{-+type instance TexArrRepr 1 = SingleTex+type instance TexArrRepr ((2 <= t) => t) = ArrayTex+-}+-- FIXME: implement properly+type instance TexArrRepr 1 = SingleTex+type instance TexArrRepr 2 = ArrayTex+type instance TexArrRepr 3 = ArrayTex+type instance TexArrRepr 4 = ArrayTex+type instance TexArrRepr 5 = ArrayTex+type instance TexArrRepr 6 = ArrayTex+type instance TexArrRepr 7 = ArrayTex+type instance TexArrRepr 8 = ArrayTex+type instance TexArrRepr 9 = ArrayTex++-- supported texture component arities+class IsColorArity a where+ toColorArity :: a -> U.ColorArity++instance IsColorArity Red where+ toColorArity _ = U.Red+instance IsColorArity RG where+ toColorArity _ = U.RG+instance IsColorArity RGB where+ toColorArity _ = U.RGB+instance IsColorArity RGBA where+ toColorArity _ = U.RGBA++-- component arity specification (Red,RG,RGB,RGBA)+-- hint: there is an interference with Shadow component format+-- alternatives:+-- A: move Shadow from TextureDataType to TextureType, this will introduce some new TextureType constructors (1D,2D,Cube,Rect)+-- B: restrict ColorArity for Shadow+-- C: add color arity definition to TextureDataType, this will solve the problem (best solution)++-- fully describes a texture type+data TextureType :: TextureShape -> TextureMipMap -> TextureArray -> Nat -> TextureSemantics * -> * -> * where -- hint: arr - single or array texture, ar - arity (Red,RG,RGB,..)+ Texture1D :: KnownNat layerCount+ => TextureDataType t ar+ -> NatNum layerCount+ -> TextureType Tex1D TexMip (TexArrRepr layerCount) layerCount t ar++ Texture2D :: KnownNat layerCount+ => TextureDataType t ar+ -> NatNum layerCount+ -> TextureType Tex2D TexMip (TexArrRepr layerCount) layerCount t ar++ Texture3D :: TextureDataType (Regular t) ar+ -> TextureType Tex3D TexMip SingleTex 1 (Regular t) ar++ TextureCube :: TextureDataType t ar+ -> TextureType Tex2D TexMip CubeTex 6 t ar++ TextureRect :: TextureDataType t ar+ -> TextureType TexRect TexNoMip SingleTex 1 t ar++ Texture2DMS :: KnownNat layerCount+ => TextureDataType (Regular t) ar+ -> NatNum layerCount+ -> TextureType Tex2D TexNoMip (TexArrRepr layerCount) layerCount (MultiSample t) ar++ TextureBuffer :: TextureDataType (Regular t) ar+ -> TextureType Tex1D TexNoMip SingleTex 1 (Buffer t) ar+++-- defines a texture+data Texture (dim :: TextureShape) (arr :: TextureArray) (t :: TextureSemantics *) ar+{-+data Texture (gp :: * -> *) (dim :: TextureShape) (arr :: TextureArray) (t :: TextureSemantics *) ar where+ TextureSlot :: (IsValidTextureSlot t)+ => ByteString -- texture slot name+ -> TextureType dim mip arr layerCount t ar+ -> Texture gp dim arr t ar+ -- TODO:+ -- add texture internal format specification+ Texture :: (IsScalar (TexSizeRepr dim), IsMipValid canMip mip, Typeable (TexDataRepr ar t), Typeable (TextureType dim canMip arr layerCount t ar), Typeable (Image layerCount (TexDataRepr ar t)))+ => TextureType dim canMip arr layerCount t ar+ -> TexSizeRepr dim+ -> MipMap mip+-- -> TexRepr dim mip gp layerCount (TexDataRepr ar t) -- FIXME: for cube it will give wrong type+ -> [gp (Image layerCount (TexDataRepr ar t))]+ -> Texture gp dim arr t ar+-}+{-+ -- TODO:+ -- swizzling (arity conversion)+ -- integral -> floating casting (floating -> integral casting if possible)+ ConvertTexture :: Texture gp dim arr t ar+ -> Texture gp dim arr t' ar'+-}++-- MipMap validation+class IsMipValid (canMip :: TextureMipMap) (mip :: TextureMipMap)+instance IsMipValid TexMip TexMip+instance IsMipValid TexMip TexNoMip+instance IsMipValid TexNoMip TexNoMip++-- restriction for texture types what can be specified as texture slots, e.g. multisample textures cannot be created im this way+class IsValidTextureSlot (a :: TextureSemantics *)+instance IsValidTextureSlot (Regular a)+instance IsValidTextureSlot (T.Shadow a)+instance IsValidTextureSlot (Buffer a)++-- type level hepler function, used for texture specification+type family TexSizeRepr (a :: TextureShape)+type instance TexSizeRepr (Tex1D) = Word32+type instance TexSizeRepr (Tex2D) = V2U+type instance TexSizeRepr (TexRect) = V2U+type instance TexSizeRepr (Tex3D) = V3U+{-+-- type level hepler function, used for texture specification+type family TexRepr dim mip (gp :: * -> *) layerCount t :: *+type instance TexRepr DIM1 NoMip gp layerCount t = gp (Image layerCount t)+type instance TexRepr DIM1 AutoMip gp layerCount t = gp (Image layerCount t)+type instance TexRepr DIM1 Mip gp layerCount t = [gp (Image layerCount t)]++type instance TexRepr DIM2 NoMip gp layerCount t = gp (Image layerCount t)+type instance TexRepr DIM2 AutoMip gp layerCount t = gp (Image layerCount t)+type instance TexRepr DIM2 Mip gp layerCount t = [gp (Image layerCount t)]++type instance TexRepr DIM3 NoMip gp layerCount t = [gp (Image layerCount t)]+type instance TexRepr DIM3 AutoMip gp layerCount t = [gp (Image layerCount t)]+type instance TexRepr DIM3 Mip gp layerCount t = [[gp (Image layerCount t)]] -- 3D layers contain mipmap+-}++-- shader stage tags: vertex, geometry, fragment+-- used in language AST, for primfun restriction and in shader codegen+data Frequency+ = Obj+ | V+ | G+ | F++data OutputType+ = SingleOutput+ | MultiOutput++deriving instance Typeable Color+deriving instance Typeable Depth+deriving instance Typeable Stencil+deriving instance Typeable Interpolated+deriving instance Typeable Obj+deriving instance Typeable V+deriving instance Typeable G+deriving instance Typeable F+deriving instance Typeable Image+deriving instance Typeable Texture+deriving instance Typeable TextureType+deriving instance Typeable SingleOutput+deriving instance Typeable MultiOutput+deriving instance Typeable TextureDataType++-- vector types: V2, V3, V4+class IsVec (dim :: Nat) vec component | vec -> dim component, dim component -> vec+instance IsVec 2 (V2 Float) Float+instance IsVec 3 (V3 Float) Float+instance IsVec 4 (V4 Float) Float+instance IsVec 2 (V2 Int32) Int32+instance IsVec 3 (V3 Int32) Int32+instance IsVec 4 (V4 Int32) Int32+instance IsVec 2 (V2 Word32) Word32+instance IsVec 3 (V3 Word32) Word32+instance IsVec 4 (V4 Word32) Word32+instance IsVec 2 (V2 Bool) Bool+instance IsVec 3 (V3 Bool) Bool+instance IsVec 4 (V4 Bool) Bool++-- scalar and vector types: scalar, V2, V3, V4+class IsVecScalar (dim :: Nat) vec component | vec -> dim component, dim component -> vec+instance IsVecScalar 1 Float Float+instance IsVecScalar 2 (V2 Float) Float+instance IsVecScalar 3 (V3 Float) Float+instance IsVecScalar 4 (V4 Float) Float+instance IsVecScalar 1 Int32 Int32+instance IsVecScalar 2 (V2 Int32) Int32+instance IsVecScalar 3 (V3 Int32) Int32+instance IsVecScalar 4 (V4 Int32) Int32+instance IsVecScalar 1 Word32 Word32+instance IsVecScalar 2 (V2 Word32) Word32+instance IsVecScalar 3 (V3 Word32) Word32+instance IsVecScalar 4 (V4 Word32) Word32+instance IsVecScalar 1 Bool Bool+instance IsVecScalar 2 (V2 Bool) Bool+instance IsVecScalar 3 (V3 Bool) Bool+instance IsVecScalar 4 (V4 Bool) Bool++-- matrix types of dimension [2..4] x [2..4]+class IsMat mat h w | mat -> h w+instance IsMat M22F V2F V2F+instance IsMat M23F V2F V3F+instance IsMat M24F V2F V4F+instance IsMat M32F V3F V2F+instance IsMat M33F V3F V3F+instance IsMat M34F V3F V4F+instance IsMat M42F V4F V2F+instance IsMat M43F V4F V3F+instance IsMat M44F V4F V4F++-- matrix, vector and scalar types+class IsMatVecScalar a t | a -> t+instance IsMatVecScalar Float Float+instance IsMatVecScalar (V2 Float) Float+instance IsMatVecScalar (V3 Float) Float+instance IsMatVecScalar (V4 Float) Float+instance IsMatVecScalar Int32 Int32+instance IsMatVecScalar (V2 Int32) Int32+instance IsMatVecScalar (V3 Int32) Int32+instance IsMatVecScalar (V4 Int32) Int32+instance IsMatVecScalar Word32 Word32+instance IsMatVecScalar (V2 Word32) Word32+instance IsMatVecScalar (V3 Word32) Word32+instance IsMatVecScalar (V4 Word32) Word32+instance IsMatVecScalar Bool Bool+instance IsMatVecScalar (V2 Bool) Bool+instance IsMatVecScalar (V3 Bool) Bool+instance IsMatVecScalar (V4 Bool) Bool+instance IsMatVecScalar M22F Float+instance IsMatVecScalar M23F Float+instance IsMatVecScalar M24F Float+instance IsMatVecScalar M32F Float+instance IsMatVecScalar M33F Float+instance IsMatVecScalar M34F Float+instance IsMatVecScalar M42F Float+instance IsMatVecScalar M43F Float+instance IsMatVecScalar M44F Float++-- matrix and vector types+class IsMatVec a t | a -> t+instance IsMatVec (V2 Float) Float+instance IsMatVec (V3 Float) Float+instance IsMatVec (V4 Float) Float+instance IsMatVec (V2 Int32) Int32+instance IsMatVec (V3 Int32) Int32+instance IsMatVec (V4 Int32) Int32+instance IsMatVec (V2 Word32) Word32+instance IsMatVec (V3 Word32) Word32+instance IsMatVec (V4 Word32) Word32+instance IsMatVec (V2 Bool) Bool+instance IsMatVec (V3 Bool) Bool+instance IsMatVec (V4 Bool) Bool+instance IsMatVec M22F Float+instance IsMatVec M23F Float+instance IsMatVec M24F Float+instance IsMatVec M32F Float+instance IsMatVec M33F Float+instance IsMatVec M34F Float+instance IsMatVec M42F Float+instance IsMatVec M43F Float+instance IsMatVec M44F Float++-- matrix or vector component type+class IsComponent a+instance IsComponent Float+instance IsComponent Int32+instance IsComponent Word32+instance IsComponent Bool+instance IsComponent V2F+instance IsComponent V3F+instance IsComponent V4F++-- matrix or vector number component type+class IsNumComponent a+instance IsNumComponent Float+instance IsNumComponent Int32+instance IsNumComponent Word32+instance IsNumComponent V2F+instance IsNumComponent V3F+instance IsNumComponent V4F++class IsSigned a+instance IsSigned Float+instance IsSigned Int++class Real a => IsNum a+instance IsNum Float+instance IsNum Int32+instance IsNum Word32++class IsIntegral a+instance IsIntegral Int32+instance IsIntegral Word32++class IsFloating a+instance IsFloating Float+instance IsFloating V2F+instance IsFloating V3F+instance IsFloating V4F+instance IsFloating M22F+instance IsFloating M23F+instance IsFloating M24F+instance IsFloating M32F+instance IsFloating M33F+instance IsFloating M34F+instance IsFloating M42F+instance IsFloating M43F+instance IsFloating M44F