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
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]
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)
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
Blend :: (BlendEquation, BlendEquation)
-> ((BlendingFactor, BlendingFactor), (BlendingFactor, BlendingFactor))
-> V4F
-> Blending Float
blend = Blend (FuncAdd,FuncAdd) ((SrcAlpha,OneMinusSrcAlpha),(SrcAlpha,OneMinusSrcAlpha)) (V4 1 1 1 1)
data VertexStream (primitive :: PrimitiveType) t
data PrimitiveStream (primitive :: PrimitiveType) clipDistances (layerCount :: Nat) (freq :: Frequency) t
data FragmentStream (layerCount :: Nat) t
data ZZ = ZZ deriving (Show,Typeable)
infixr 1 :+:
data tail :+: head = !tail :+: !head deriving (Show,Typeable)
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)
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
data Color a
data Depth a
data Stencil a
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)
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
triangleCtx :: RasterContext Triangle
triangleCtx = TriangleCtx CullNone PolygonFill NoOffset LastVertex
class NoConstraint a
instance NoConstraint a
type FrameBuffer layerCount t = FlatTuple NoConstraint (Image layerCount) t
data FragmentOperation ty where
DepthOp :: DepthFunction
-> Bool
-> 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
-> mask
-> FragmentOperation (Color color)
data Image (layerCount :: Nat) t where
DepthImage :: KnownNat layerCount
=> NatNum layerCount
-> Float
-> Image layerCount (Depth Float)
StencilImage :: KnownNat layerCount
=> NatNum layerCount
-> Int32
-> Image layerCount (Stencil Int32)
ColorImage :: (IsNum t, IsVecScalar d color t, IsScalar color, KnownNat layerCount)
=> NatNum layerCount
-> color
-> Image layerCount (Color color)
UnclearedImage :: (IsNum t, IsVecScalar d color t, IsScalar color, KnownNat layerCount)
=> NatNum layerCount
-> Image layerCount (Color 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)
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)
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)
type family ColorRepr a :: *
type instance ColorRepr ZZ = ZZ
type instance ColorRepr (a :+: b) = Color a :+: (ColorRepr b)
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)
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
-> Int
-> MipMap TexMip
AutoMip :: Int
-> Int
-> MipMap TexMip
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
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
type family TexArrRepr (a :: Nat) :: TextureArray
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
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
data TextureType :: TextureShape -> TextureMipMap -> TextureArray -> Nat -> TextureSemantics * -> * -> * where
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
data Texture (dim :: TextureShape) (arr :: TextureArray) (t :: TextureSemantics *) ar
class IsMipValid (canMip :: TextureMipMap) (mip :: TextureMipMap)
instance IsMipValid TexMip TexMip
instance IsMipValid TexMip TexNoMip
instance IsMipValid TexNoMip TexNoMip
class IsValidTextureSlot (a :: TextureSemantics *)
instance IsValidTextureSlot (Regular a)
instance IsValidTextureSlot (T.Shadow a)
instance IsValidTextureSlot (Buffer a)
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
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
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
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
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
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
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
class IsComponent a
instance IsComponent Float
instance IsComponent Int32
instance IsComponent Word32
instance IsComponent Bool
instance IsComponent V2F
instance IsComponent V3F
instance IsComponent V4F
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