fwgl 0.1.0.3 → 0.1.1.0
raw patch · 14 files changed
+207/−169 lines, 14 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- FWGL.Graphics.Types: data Light
- FWGL.Internal.TList: instance (Subset '[x] ys, Subset xs ys) => Subset (x : xs) ys
- FWGL.Internal.TList: instance Subset '[] ys
- FWGL.Internal.TList: type NotMember x xs = IsMember x xs ~ False
- FWGL.Shader: (>>) :: Shader g i o a -> Shader g i o b -> Shader g i o b
- FWGL.Shader: (>>=) :: Shader g i o a -> (a -> Shader g i o b) -> Shader g i o b
- FWGL.Shader: fail :: String -> Shader g i o a
- FWGL.Shader: get :: (Member a i, Typeable a, ShaderType a) => Shader g i o a
- FWGL.Shader: global :: (Member a g, Typeable a, ShaderType a) => Shader g i o a
- FWGL.Shader: put :: (Member a o, Typeable a, ShaderType a) => a -> Shader g i o ()
- FWGL.Shader: putFragment :: Member FragmentShaderOutput o => V4 -> Shader g i o ()
- FWGL.Shader: putVertex :: Member VertexShaderOutput o => V4 -> Shader g i o ()
- FWGL.Shader: return :: a -> Shader g i o a
- FWGL.Shader.Default3D: applyMatrices :: Shader '[Transform3, View3] '[Position3] [] V4
- FWGL.Shader.Language: Nil :: Expr
- FWGL.Shader.Monad: (>>) :: Shader g i o a -> Shader g i o b -> Shader g i o b
- FWGL.Shader.Monad: (>>=) :: Shader g i o a -> (a -> Shader g i o b) -> Shader g i o b
- FWGL.Shader.Monad: Bind :: Shader g' i' o' b -> (b -> Shader g'' i'' o'' a) -> Shader g i o a
- FWGL.Shader.Monad: Get :: Shader g i o a
- FWGL.Shader.Monad: Global :: Shader g i o a
- FWGL.Shader.Monad: Pure :: a -> Shader g i o a
- FWGL.Shader.Monad: Put :: a -> Shader g i o ()
- FWGL.Shader.Monad: class AllTypeable (xs :: [*])
- FWGL.Shader.Monad: class Subset (xs :: [*]) (ys :: [*])
- FWGL.Shader.Monad: data Shader g i o a
- FWGL.Shader.Monad: fail :: String -> Shader g i o a
- FWGL.Shader.Monad: get :: (Member a i, Typeable a, ShaderType a) => Shader g i o a
- FWGL.Shader.Monad: global :: (Member a g, Typeable a, ShaderType a) => Shader g i o a
- FWGL.Shader.Monad: instance (Typeable x, AllTypeable xs) => AllTypeable (x : xs)
- FWGL.Shader.Monad: instance AllTypeable '[]
- FWGL.Shader.Monad: put :: (Member a o, Typeable a, ShaderType a) => a -> Shader g i o ()
- FWGL.Shader.Monad: return :: a -> Shader g i o a
- FWGL.Shader.Monad: type Equal xs ys = (Subset xs ys, Subset ys xs)
- FWGL.Shader.Monad: type Member x xs = Subset '[x] xs
- FWGL.Shader.Monad: type PartialShader g i o a = (Subset o o', Subset g g', Subset i i', Subset i' i) => Shader g' i' o' a
- FWGL.Shader.Stages: putFragment :: Member FragmentShaderOutput o => V4 -> Shader g i o ()
- FWGL.Shader.Stages: putVertex :: Member VertexShaderOutput o => V4 -> Shader g i o ()
+ FWGL.Graphics.Custom: data Program (gs :: [*]) (is :: [*])
+ FWGL.Graphics.D2: data Program (gs :: [*]) (is :: [*])
+ FWGL.Graphics.D3: data Program (gs :: [*]) (is :: [*])
+ FWGL.Internal.TList: instance IsSubset xs ys ~ 'True => Subset xs ys
+ FWGL.Internal.TList: type Reverse xs = Reverse' xs []
+ FWGL.Shader: (:-) :: a -> STList xs -> STList (a : xs)
+ FWGL.Shader: Fragment :: V4 -> FragmentShaderOutput
+ FWGL.Shader: N :: STList []
+ FWGL.Shader: Vertex :: V4 -> VertexShaderOutput
+ FWGL.Shader: data STList :: [*] -> *
+ FWGL.Shader: newtype FragmentShaderOutput
+ FWGL.Shader: newtype VertexShaderOutput
+ FWGL.Shader.Language: Empty :: Expr
+ FWGL.Shader.Language: class Mul a b c | a b -> c
+ FWGL.Shader.Language: class Sum a
+ FWGL.Shader.Shader: (:-) :: a -> STList xs -> STList (a : xs)
+ FWGL.Shader.Shader: N :: STList []
+ FWGL.Shader.Shader: class AllTypeable (xs :: [*])
+ FWGL.Shader.Shader: class Subset (xs :: [*]) (ys :: [*])
+ FWGL.Shader.Shader: data STList :: [*] -> *
+ FWGL.Shader.Shader: instance (ShaderType x, Typeable x, StaticList xs) => StaticList (x : xs)
+ FWGL.Shader.Shader: instance (ShaderType x, Typeable x, StaticSTList xs, IsMember x xs ~ 'False) => StaticSTList (x : xs)
+ FWGL.Shader.Shader: instance (Typeable x, AllTypeable xs) => AllTypeable (x : xs)
+ FWGL.Shader.Shader: instance AllTypeable '[]
+ FWGL.Shader.Shader: instance StaticList '[]
+ FWGL.Shader.Shader: instance StaticSTList '[]
+ FWGL.Shader.Shader: stFold :: (forall x. (Typeable x, ShaderType x) => acc -> x -> acc) -> acc -> STList xs -> acc
+ FWGL.Shader.Shader: staticList :: StaticList xs => Proxy (xs :: [*]) -> (forall x. (Typeable x, ShaderType x) => x -> y) -> [y]
+ FWGL.Shader.Shader: staticSTList :: StaticSTList xs => Proxy (xs :: [*]) -> (forall x. (Typeable x, ShaderType x) => x -> x) -> STList xs
+ FWGL.Shader.Shader: type Equal xs ys = And (IsSubset xs ys) (IsSubset ys xs) ~ True
+ FWGL.Shader.Shader: type Member x xs = IsMember x xs ~ True
+ FWGL.Shader.Shader: type Shader gs is os = STList gs -> STList is -> STList os
+ FWGL.Shader.Shader: type Valid gs is os = (StaticList gs, StaticList is, StaticList os, StaticSTList gs, StaticSTList is, StaticSTList os)
+ FWGL.Shader.Stages: Fragment :: V4 -> FragmentShaderOutput
+ FWGL.Shader.Stages: Vertex :: V4 -> VertexShaderOutput
+ FWGL.Shader.Stages: newtype FragmentShaderOutput
+ FWGL.Shader.Stages: newtype VertexShaderOutput
+ FWGL.Shader.Stages: type ValidVertex g i o = (Valid g i o, IsMember VertexShaderOutput o ~ False)
- FWGL.Graphics.Custom: program :: (Subset gs' gs, Subset gs'' gs, Subset os' os) => VertexShader gs' is os -> FragmentShader gs'' os' -> Program gs is
+ FWGL.Graphics.Custom: program :: (ValidVertex vgs vis vos, Valid fgs vos [], Equal pgs (Union vgs fgs)) => VertexShader vgs vis vos -> FragmentShader fgs vos -> Program pgs vis
- FWGL.Graphics.D2: program :: (Subset gs' gs, Subset gs'' gs, Subset os' os) => VertexShader gs' is os -> FragmentShader gs'' os' -> Program gs is
+ FWGL.Graphics.D2: program :: (ValidVertex vgs vis vos, Valid fgs vos [], Equal pgs (Union vgs fgs)) => VertexShader vgs vis vos -> FragmentShader fgs vos -> Program pgs vis
- FWGL.Internal.TList: type Equal xs ys = (Subset xs ys, Subset ys xs)
+ FWGL.Internal.TList: type Equal xs ys = And (IsSubset xs ys) (IsSubset ys xs) ~ True
- FWGL.Internal.TList: type Member x xs = Subset '[x] xs
+ FWGL.Internal.TList: type Member x xs = IsMember x xs ~ True
- FWGL.Shader: type FragmentShader g i = Shader g i (FragmentShaderOutput : []) ()
+ FWGL.Shader: type FragmentShader g i = Shader g i (FragmentShaderOutput : [])
- FWGL.Shader: type Shader g i o a = PartialShader g i o a
+ FWGL.Shader: type Shader gs is os = STList gs -> STList is -> STList os
- FWGL.Shader: type VertexShader g i o = Shader g i (VertexShaderOutput : o) ()
+ FWGL.Shader: type VertexShader g i o = Shader g i (VertexShaderOutput : o)
- FWGL.Shader.Default3D: vertexShader :: VertexShader '[Transform3, View3] '[Position3, UV, Normal3] '[UV]
+ FWGL.Shader.Default3D: vertexShader :: VertexShader '[Transform3, View3] '[Position3, UV, Normal3] '[UV, Normal3]
- FWGL.Shader.GLSL: fragmentToGLSL :: FragmentShader g i -> String
+ FWGL.Shader.GLSL: fragmentToGLSL :: Valid g i [] => FragmentShader g i -> String
- FWGL.Shader.GLSL: vertexToGLSL :: VertexShader g i o -> String
+ FWGL.Shader.GLSL: vertexToGLSL :: ValidVertex g i o => VertexShader g i o -> String
- FWGL.Shader.GLSL: vertexToGLSLAttr :: VertexShader g i o -> (String, [(String, Int)])
+ FWGL.Shader.GLSL: vertexToGLSLAttr :: ValidVertex g i o => VertexShader g i o -> (String, [(String, Int)])
- FWGL.Shader.Program: program :: (Subset gs' gs, Subset gs'' gs, Subset os' os) => VertexShader gs' is os -> FragmentShader gs'' os' -> Program gs is
+ FWGL.Shader.Program: program :: (ValidVertex vgs vis vos, Valid fgs vos [], Equal pgs (Union vgs fgs)) => VertexShader vgs vis vos -> FragmentShader fgs vos -> Program pgs vis
- FWGL.Shader.Stages: type FragmentShader g i = Shader g i (FragmentShaderOutput : []) ()
+ FWGL.Shader.Stages: type FragmentShader g i = Shader g i (FragmentShaderOutput : [])
- FWGL.Shader.Stages: type VertexShader g i o = Shader g i (VertexShaderOutput : o) ()
+ FWGL.Shader.Stages: type VertexShader g i o = Shader g i (VertexShaderOutput : o)
Files
- FWGL/Graphics/D2.hs +1/−0
- FWGL/Graphics/D3.hs +1/−0
- FWGL/Graphics/Draw.hs +18/−3
- FWGL/Internal/TList.hs +32/−10
- FWGL/Shader.hs +7/−4
- FWGL/Shader/Default2D.hs +8/−14
- FWGL/Shader/Default3D.hs +9/−22
- FWGL/Shader/GLSL.hs +35/−24
- FWGL/Shader/Language.hs +3/−2
- FWGL/Shader/Monad.hs +0/−66
- FWGL/Shader/Program.hs +10/−7
- FWGL/Shader/Shader.hs +69/−0
- FWGL/Shader/Stages.hs +12/−15
- fwgl.cabal +2/−2
FWGL/Graphics/D2.hs view
@@ -34,6 +34,7 @@ elements, view, -- ** Object layers+ Program, layer, layerPrg, program,
FWGL/Graphics/D3.hs view
@@ -34,6 +34,7 @@ elements, view, -- ** Object layers+ Program, layer, layerPrg, program,
FWGL/Graphics/Draw.hs view
@@ -39,7 +39,11 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.State -drawInit :: (BackendIO, GLES) => Int -> Int -> GL DrawState+-- | Create a 'DrawState'.+drawInit :: (BackendIO, GLES)+ => Int -- ^ Viewport width+ -> Int -- ^ Viewport height+ -> GL DrawState drawInit w h = do enable gl_DEPTH_TEST enable gl_BLEND blendFunc gl_SRC_ALPHA gl_ONE_MINUS_SRC_ALPHA@@ -55,18 +59,27 @@ where newGLResMap :: (Hashable i, Resource i r GL) => ResMap i r newGLResMap = newResMap -execDraw :: Draw () -> DrawState -> GL DrawState+-- | Execute a 'Draw' action.+execDraw :: Draw () -- ^ Action.+ -> DrawState -- ^ State.+ -> GL DrawState execDraw (Draw a) = execStateT a -resize :: GLES => Int -> Int -> GL ()+-- | Viewport.+resize :: GLES+ => Int -- ^ Width.+ -> Int -- ^ Height.+ -> GL () resize w h = viewport 0 0 (fromIntegral w) (fromIntegral h) +-- | Clear the buffers. drawBegin :: GLES => Draw () drawBegin = gl . clear $ gl_COLOR_BUFFER_BIT .|. gl_DEPTH_BUFFER_BIT drawEnd :: GLES => Draw () drawEnd = return () +-- | Draw a 'Layer'. drawLayer :: (GLES, BackendIO) => Layer -> Draw () drawLayer (Layer prg obj) = setProgram prg >> drawObject obj drawLayer (SubLayer w' h' sub sup) =@@ -101,11 +114,13 @@ bindTexture gl_TEXTURE_2D wtex return $ ActiveTexture 0 +-- | Get the dimensions of a 'Texture'. textureSize :: (GLES, BackendIO, Num a) => Texture -> Draw (a, a) textureSize tex = withRes (getTexture tex) (return (0, 0)) $ \(LoadedTexture w h _) -> return ( fromIntegral w , fromIntegral h) +-- | Set the program. setProgram :: GLES => Program g i -> Draw () setProgram p = do current <- program <$> Draw get when (current /= Just (castProgram p)) $
FWGL/Internal/TList.hs view
@@ -2,18 +2,23 @@ TypeOperators, UndecidableInstances, FlexibleContexts, FlexibleInstances, ConstraintKinds, PolyKinds #-} -module FWGL.Internal.TList where--class Subset (xs :: [*]) (ys :: [*])-instance Subset '[] ys-instance (Subset '[x] ys, Subset xs ys) => Subset (x ': xs) ys--- BUG: Subset x x?+module FWGL.Internal.TList (+ Equal,+ Member,+ IsMember,+ Subset,+ IsSubset,+ Remove,+ Difference,+ Append,+ Insert,+ Reverse,+ Union+) where --- class Equal (xs :: [*]) (ys :: [*])--- instance (Subset xs ys, Subset ys xs) => Equal xs ys-type Equal xs ys = (Subset xs ys, Subset ys xs)+type Equal xs ys = And (IsSubset xs ys) (IsSubset ys xs) ~ True -type Member x xs = Subset '[x] xs+type Member x xs = IsMember x xs ~ True type NotMember x xs = IsMember x xs ~ False @@ -22,6 +27,13 @@ IsMember x (x ': xs) = True IsMember y (x ': xs) = IsMember y xs +type family IsSubset (xs :: [*]) (ys :: [*]) :: Bool where+ IsSubset xs xs = True+ IsSubset '[] ys = True+ IsSubset (x ': xs) ys = And (IsMember x ys) (IsSubset xs ys)++class Subset (xs :: [*]) (ys :: [*])+instance IsSubset xs ys ~ 'True => Subset xs ys type family Remove x (xs :: [*]) where Remove x '[] = '[] Remove x (x ': xs) = Remove x xs@@ -40,6 +52,12 @@ Insert y (y ': xs) = y ': xs Insert y (x ': xs) = x ': Insert y xs +type Reverse xs = Reverse' xs '[]++type family Reverse' (xs :: [*]) (ys :: [*]) where+ Reverse' '[] ys = ys+ Reverse' (x ': xs) ys = Reverse' xs (x ': ys)+ type family Union (xs :: [*]) (ys :: [*]) where Union '[] ys = ys Union (x ': xs) ys = Union xs (Insert x ys)@@ -47,3 +65,7 @@ type family TypeEq (x :: k) (y :: k) :: Bool where TypeEq x x = True TypeEq x y = False++type family And (a :: Bool) (b :: Bool) :: Bool where+ And True True = True+ And a b = False
FWGL/Shader.hs view
@@ -1,9 +1,11 @@-{-# LANGUAGE FlexibleContexts, RankNTypes #-}+{-# LANGUAGE FlexibleContexts, RankNTypes, TypeFamilies #-} module FWGL.Shader ( Shader, VertexShader, FragmentShader,+ VertexShaderOutput(Vertex),+ FragmentShaderOutput(Fragment), Typeable, AllTypeable, ShaderType,@@ -44,6 +46,8 @@ sign, sqrt, texture2D,+ STList((:-), N),+ {- (>>=), (>>), fail,@@ -53,6 +57,7 @@ put, putVertex, putFragment,+ -} (.), id, const,@@ -64,13 +69,11 @@ import qualified FWGL.Internal.GL as CPU import FWGL.Shader.CPU (UniformCPU, AttributeCPU) import FWGL.Shader.Language-import FWGL.Shader.Monad hiding (Shader)+import FWGL.Shader.Shader import FWGL.Shader.Stages import qualified FWGL.Vector as CPU import Prelude ((.), id, const, flip, ($)) import qualified Prelude as CPU--type Shader g i o a = PartialShader g i o a type CFloat = CPU.Float type CSampler2D = CPU.ActiveTexture
FWGL/Shader/Default2D.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, DataKinds,- FlexibleContexts, RebindableSyntax, TypeFamilies #-}+{-# LANGUAGE DataKinds, RebindableSyntax, DeriveDataTypeable,+ GeneralizedNewtypeDeriving, GADTs #-} module FWGL.Shader.Default2D where @@ -33,17 +33,11 @@ vertexShader :: VertexShader '[Transform2, View2, Depth] '[Position2, UV] '[UV]-vertexShader = do (Position2 (V2 x y)) <- get- uv@(UV _) <- get- Transform2 trans <- global- View2 view <- global- Depth z <- global- let V3 x' y' _ = view * trans * V3 x y 1- putVertex $ V4 x' y' z 1- put uv- -- BUG+vertexShader (Transform2 trans :- View2 view :- Depth z :- N)+ (Position2 (V2 x y) :- uv@(UV _) :- N) =+ let V3 x' y' _ = view * trans * V3 x y 1+ in Vertex (V4 x' y' z 1) :- uv :- N fragmentShader :: FragmentShader '[Image] '[UV]-fragmentShader = do Image sampler <- global- UV (V2 s t) <- get- putFragment $ texture2D sampler (V2 s $ 1 - t)+fragmentShader (Image sampler :- N) (UV (V2 s t) :- N) =+ Fragment (texture2D sampler (V2 s $ 1 - t)) :- N
FWGL/Shader/Default3D.hs view
@@ -1,9 +1,8 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveDataTypeable, DataKinds,- FlexibleContexts, RebindableSyntax, TypeFamilies #-}+{-# LANGUAGE DataKinds, RebindableSyntax, DeriveDataTypeable,+ GeneralizedNewtypeDeriving, GADTs #-} module FWGL.Shader.Default3D where -import FWGL.Shader.CPU import FWGL.Shader import qualified FWGL.Vector @@ -30,24 +29,12 @@ vertexShader :: VertexShader '[ Transform3, View3 ] '[ Position3, UV, Normal3 ]- '[ UV ]-vertexShader = do v <- applyMatrices- get >>= \x@(UV _) -> put x- (Normal3 _) <- get- putVertex v--applyMatrices :: Shader '[ Transform3, View3 ]- '[ Position3 ]- '[]- V4-applyMatrices = do View3 viewMatrix <- global- Transform3 modelMatrix <- global- Position3 (V3 x y z) <- get- return $- viewMatrix * modelMatrix * V4 x y z 1.0+ '[ UV, Normal3 ]+vertexShader (Transform3 modelMatrix :- View3 viewMatrix :- N)+ (Position3 (V3 x y z) :- uv@(UV _) :- norm@(Normal3 _) :- N) =+ let v = viewMatrix * modelMatrix * V4 x y z 1.0+ in Vertex v :- uv :- norm :- N fragmentShader :: FragmentShader '[ Texture2 ] [ UV, Normal3 ]-fragmentShader = do Texture2 sampler <- global- UV (V2 s t) <- get- putFragment .- texture2D sampler $ V2 s (1 - t)+fragmentShader (Texture2 sampler :- N) (UV (V2 s t) :- Normal3 _ :- N) =+ Fragment (texture2D sampler $ V2 s (1 - t)) :- N
FWGL/Shader/GLSL.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE ScopedTypeVariables, GADTs, RankNTypes, FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables, GADTs, RankNTypes, FlexibleContexts,+ KindSignatures, DataKinds, TypeOperators, ConstraintKinds #-} module FWGL.Shader.GLSL ( vertexToGLSLAttr,@@ -11,28 +12,29 @@ ) where import Data.Typeable-import FWGL.Shader.Monad (Shader(..))+import FWGL.Shader.Shader import FWGL.Shader.Language (Expr(..), ShaderType(..))-import FWGL.Shader.Stages (VertexShader, FragmentShader)+import FWGL.Shader.Stages (VertexShader, FragmentShader, ValidVertex) type ShaderVars = ( [(String, String)] , [(String, String, Int)] , [(String, String, Expr)]) -vertexToGLSLAttr :: VertexShader g i o -> (String, [(String, Int)])+vertexToGLSLAttr :: ValidVertex g i o => VertexShader g i o+ -> (String, [(String, Int)]) vertexToGLSLAttr v =- let r@(_, is, _) = snd $ reduce False v+ let r@(_, is, _) = vars False v in ( shaderToGLSL "#version 100\n" "attribute" "varying" r [("hvVertexShaderOutput", "gl_Position")] , map (\(t, n, s) -> (n, s)) is) -vertexToGLSL :: VertexShader g i o -> String+vertexToGLSL :: ValidVertex g i o => VertexShader g i o -> String vertexToGLSL = fst . vertexToGLSLAttr -fragmentToGLSL :: FragmentShader g i -> String+fragmentToGLSL :: Valid g i '[] => FragmentShader g i -> String fragmentToGLSL v = shaderToGLSL "#version 100\nprecision mediump float;" "varying" ""- (snd $ reduce True v)+ (vars True v) [("hvFragmentShaderOutput", "gl_FragColor")] shaderToGLSL :: String -> String -> String -> ShaderVars -> [(String, String)] -> String@@ -52,24 +54,33 @@ ((_, y) : []) -> y _ -> x -reduce :: Bool -> Shader g i o a -> (a, ShaderVars)-reduce _ (Pure x) = (x, ([], [], []))-reduce b (Bind s f) = case reduce b s of- (x, (gs, is, os)) -> case reduce b $ f x of- (y, (gs', is', os')) ->- (y, (gs ++ gs', is ++ is', os ++ os'))-reduce _ (Global :: Shader g i o a) = (fromExpr $ Read nm, ([(ty, nm)], [], []))- where (ty, nm) = globalTypeAndName (undefined :: a)-reduce isFragment (Get :: Shader g i o a) =- (fromExpr $ Read nm, ([], [(ty, nm, size (undefined :: a))], []))- where (ty, nm) = (if isFragment- then varyingTypeAndName- else attributeTypeAndName) (undefined :: a)-reduce _ (Put x) = ((), ([], [], [(ty, nm, toExpr x)]))- where (ty, nm) = varyingTypeAndName x+vars :: Valid gs is os => Bool -> Shader gs is os -> ShaderVars+vars isFragment (shader :: Shader gs is os) =+ ( staticList (undefined :: Proxy gs) globalTypeAndName+ , staticList (undefined :: Proxy is) inputVar+ , stFold (\acc x -> outputVar x : acc) [] outputs)+ where outputs = shader (staticSTList (undefined :: Proxy gs) globalExpr)+ (staticSTList (undefined :: Proxy is) inputExpr) + globalExpr, inputExpr :: (Typeable x, ShaderType y) => x -> y+ globalExpr x = fromExpr . Read $ globalName x+ inputExpr x = fromExpr . Read $ if isFragment then varyingName x+ else attributeName x++ inputVar :: (Typeable x, ShaderType x)+ => x -> (String, String, Int)+ inputVar x = let (ty, nm) = if isFragment+ then varyingTypeAndName x+ else attributeTypeAndName x+ in (ty, nm, size x)++ outputVar :: (Typeable x, ShaderType x)+ => x -> (String, String, Expr)+ outputVar x = let (ty, nm) = varyingTypeAndName x+ in (ty, nm, toExpr x)+ exprToGLSL :: Expr -> String-exprToGLSL Nil = ""+exprToGLSL Empty = "" exprToGLSL (Read s) = s exprToGLSL (Op1 s e) = "(" ++ s ++ exprToGLSL e ++ ")" exprToGLSL (Op2 s x y) = "(" ++ exprToGLSL x ++ s ++ exprToGLSL y ++ ")"
FWGL/Shader/Language.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, FunctionalDependencies #-}+{-# LANGUAGE GADTs, MultiParamTypeClasses, DeriveDataTypeable, DataKinds,+ FunctionalDependencies #-} module FWGL.Shader.Language ( ShaderType(..),@@ -38,7 +39,7 @@ import qualified Prelude import Text.Printf -data Expr = Nil | Read String | Op1 String Expr | Op2 String Expr Expr+data Expr = Empty | Read String | Op1 String Expr | Op2 String Expr Expr | Apply String [Expr] | X Expr | Y Expr | Z Expr | W Expr | Literal String deriving (Prelude.Eq)
− FWGL/Shader/Monad.hs
@@ -1,66 +0,0 @@-{-# LANGUAGE GADTs, DataKinds, KindSignatures, TypeOperators,- RankNTypes, FlexibleContexts #-}--module FWGL.Shader.Monad (- Shader(..),- PartialShader,- Member,- AllTypeable,- Subset,- Equal,- Union,- Insert,- return,- get,- global,- put,- (>>),- (>>=),- fail-) where--import Data.Typeable-import FWGL.Internal.TList-import FWGL.Shader.Language (ShaderType)-import Prelude (String, error)--data Shader g i o a where- Pure :: a -> Shader g i o a- Bind :: Shader g' i' o' b- -> (b -> Shader g'' i'' o'' a)- -> Shader g i o a- Get :: (Member a i, Typeable a, ShaderType a) => Shader g i o a- Global :: (Member a g, Typeable a, ShaderType a) => Shader g i o a- -- Put :: (Typeable a, ShaderType a) => a -> Shader g i (a ': o) ()- Put :: (Member a o, Typeable a, ShaderType a) => a -> Shader g i o ()--type PartialShader g i o a =- (Subset o o', Subset g g', Subset i i', Subset i' i)- => Shader g' i' o' a---- TODO: Shader è una monade e un funtore, non c'è bisogno di rebindare la--- sintassi-return :: a -> Shader g i o a-return = Pure--get :: (Member a i, Typeable a, ShaderType a) => Shader g i o a-get = Get--global :: (Member a g, Typeable a, ShaderType a) => Shader g i o a-global = Global--put :: (Member a o, Typeable a, ShaderType a) => a -> Shader g i o ()-put = Put--fail :: String -> Shader g i o a-fail = error--(>>=) :: Shader g i o a -> (a -> Shader g i o b) -> Shader g i o b-(>>=) = Bind--(>>) :: Shader g i o a -> Shader g i o b -> Shader g i o b-x >> y = x >>= \_ -> y--class AllTypeable (xs :: [*])-instance AllTypeable '[]-instance (Typeable x, AllTypeable xs) => AllTypeable (x ': xs)
FWGL/Shader/Program.hs view
@@ -1,7 +1,8 @@-{-# LANGUAGE MultiParamTypeClasses, ExistentialQuantification,- FunctionalDependencies, KindSignatures, DataKinds,+{-# LANGUAGE MultiParamTypeClasses, ExistentialQuantification, ConstraintKinds,+ FunctionalDependencies, KindSignatures, DataKinds, GADTs, RankNTypes, FlexibleInstances, ScopedTypeVariables,- TypeOperators, ImpredicativeTypes, TypeSynonymInstances #-}+ TypeOperators, ImpredicativeTypes, TypeSynonymInstances,+ FlexibleContexts #-} module FWGL.Shader.Program ( LoadedProgram(..),@@ -23,11 +24,12 @@ import qualified FWGL.Shader.Default2D as Default2D import qualified FWGL.Shader.Default3D as Default3D import FWGL.Shader.GLSL-import FWGL.Shader.Monad (Subset, Union, Insert)+import FWGL.Shader.Shader (Valid) import FWGL.Shader.Stages import FWGL.Internal.GL hiding (Program) import qualified FWGL.Internal.GL as GL import FWGL.Internal.Resource+import FWGL.Internal.TList import Unsafe.Coerce -- | A vertex shader associated with a compatible fragment shader.@@ -71,9 +73,10 @@ castProgram = unsafeCoerce -- | Create a 'Program' from the shaders.-program :: (Subset gs' gs, Subset gs'' gs, Subset os' os)- => VertexShader gs' is os -> FragmentShader gs'' os'- -> Program gs is+program :: (ValidVertex vgs vis vos, Valid fgs vos '[],+ Equal pgs (Union vgs fgs))+ => VertexShader vgs vis vos -> FragmentShader fgs vos+ -> Program pgs vis program vs fs = let (vss, attrs) = vertexToGLSLAttr vs fss = fragmentToGLSL fs in Program (vss, attrs) fss (hash (vss, fss))
+ FWGL/Shader/Shader.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE GADTs, DataKinds, KindSignatures, TypeOperators,+ RankNTypes, FlexibleContexts, ScopedTypeVariables,+ MultiParamTypeClasses, FlexibleInstances, ConstraintKinds #-}++module FWGL.Shader.Shader (+ Shader(..),+ Valid,+ Member,+ AllTypeable,+ Subset,+ Equal,+ Union,+ Insert,+ STList(..),+ stFold,+ staticList,+ staticSTList+) where++import Data.Typeable+import FWGL.Internal.TList+import FWGL.Shader.Language (ShaderType)+import Prelude (String, error, Bool(False), undefined)++infixr 4 :-++data STList :: [*] -> * where+ N :: STList '[]+ (:-) :: (ShaderType a, Typeable a, IsMember a xs ~ False)+ => a -> STList xs -> STList (a ': xs)++type Valid gs is os = ( StaticList gs, StaticList is, StaticList os+ , StaticSTList gs, StaticSTList is, StaticSTList os)++type Shader gs is os = STList gs -> STList is -> STList os++stFold :: (forall x. (Typeable x, ShaderType x) => acc -> x -> acc)+ -> acc -> STList xs -> acc+stFold _ acc N = acc+stFold f acc (x :- xs) = stFold f (f acc x) xs++class StaticList (xs :: [*]) where+ staticList :: Proxy (xs :: [*])+ -> (forall x. (Typeable x, ShaderType x) => x -> y)+ -> [y]++instance StaticList '[] where+ staticList (_ :: Proxy '[]) _ = []++instance (ShaderType x, Typeable x, StaticList xs) => StaticList (x ': xs) where+ staticList (_ :: Proxy (x ': xs)) f =+ f (undefined :: x) : staticList (undefined :: Proxy xs) f++class StaticSTList (xs :: [*]) where+ staticSTList :: Proxy (xs :: [*])+ -> (forall x. (Typeable x, ShaderType x) => x -> x)+ -> STList xs++instance StaticSTList '[] where+ staticSTList (_ :: Proxy '[]) _ = N++instance (ShaderType x, Typeable x, StaticSTList xs, IsMember x xs ~ False) =>+ StaticSTList (x ': xs) where+ staticSTList (_ :: Proxy (x ': xs)) f =+ f (undefined :: x) :- staticSTList (undefined :: Proxy xs) f++class AllTypeable (xs :: [*])+instance AllTypeable '[]+instance (Typeable x, AllTypeable xs) => AllTypeable (x ': xs)
FWGL/Shader/Stages.hs view
@@ -1,28 +1,25 @@ {-# LANGUAGE TypeOperators, DataKinds, GeneralizedNewtypeDeriving,- DeriveDataTypeable, RankNTypes, FlexibleContexts #-}+ DeriveDataTypeable, RankNTypes, FlexibleContexts,+ TypeFamilies, ConstraintKinds #-} module FWGL.Shader.Stages ( VertexShader,+ ValidVertex, FragmentShader,- putVertex,- putFragment+ VertexShaderOutput(Vertex),+ FragmentShaderOutput(Fragment) ) where import Data.Typeable +import FWGL.Internal.TList import FWGL.Shader.Language-import FWGL.Shader.Monad--type VertexShader g i o = Shader g i (VertexShaderOutput ': o) ()-type FragmentShader g i = Shader g i (FragmentShaderOutput ': '[]) ()+import FWGL.Shader.Shader -newtype VertexShaderOutput = VSO V4 deriving (Typeable, ShaderType)-newtype FragmentShaderOutput = FSO V4 deriving (Typeable, ShaderType)+type VertexShader g i o = Shader g i (VertexShaderOutput ': o)+type FragmentShader g i = Shader g i (FragmentShaderOutput ': '[]) -putVertex :: Member VertexShaderOutput o => V4 -> Shader g i o ()--- putVertex :: V4 -> Shader '[] '[] (VertexShaderOutput ': '[]) ()-putVertex = put . VSO+type ValidVertex g i o = (Valid g i o, IsMember VertexShaderOutput o ~ False) -putFragment :: Member FragmentShaderOutput o => V4 -> Shader g i o ()--- putFragment :: V4 -> Shader '[] '[] (FragmentShaderOutput ': '[]) ()-putFragment = put . FSO+newtype VertexShaderOutput = Vertex V4 deriving (Typeable, ShaderType)+newtype FragmentShaderOutput = Fragment V4 deriving (Typeable, ShaderType)
fwgl.cabal view
@@ -1,5 +1,5 @@ name: fwgl-version: 0.1.0.3+version: 0.1.1.0 synopsis: FRP 2D/3D game engine description: FRP 2D/3D game engine (work in progress). homepage: https://github.com/ZioCrocifisso/FWGL@@ -13,7 +13,7 @@ cabal-version: >=1.10 library- exposed-modules: FWGL, FWGL.Shader, FWGL.Geometry, FWGL.Utils, FWGL.Vector, FWGL.Audio, FWGL.Key, FWGL.Backend, FWGL.Input, FWGL.Graphics.Draw, FWGL.Graphics.D2, FWGL.Graphics.D3, FWGL.Graphics.Texture, FWGL.Graphics.Types, FWGL.Graphics.Color, FWGL.Graphics.Custom, FWGL.Graphics.Shapes, FWGL.Internal.GL, FWGL.Internal.TList, FWGL.Geometry.OBJ, FWGL.Shader.GLSL, FWGL.Shader.Stages, FWGL.Shader.Program, FWGL.Shader.CPU, FWGL.Shader.Default3D, FWGL.Shader.Monad, FWGL.Shader.Language, FWGL.Shader.Default2D, FWGL.Backend.GLES, FWGL.Backend.IO+ exposed-modules: FWGL, FWGL.Shader, FWGL.Geometry, FWGL.Utils, FWGL.Vector, FWGL.Audio, FWGL.Key, FWGL.Backend, FWGL.Input, FWGL.Graphics.Draw, FWGL.Graphics.D2, FWGL.Graphics.D3, FWGL.Graphics.Texture, FWGL.Graphics.Types, FWGL.Graphics.Color, FWGL.Graphics.Custom, FWGL.Graphics.Shapes, FWGL.Internal.GL, FWGL.Internal.TList, FWGL.Geometry.OBJ, FWGL.Shader.GLSL, FWGL.Shader.Stages, FWGL.Shader.Program, FWGL.Shader.CPU, FWGL.Shader.Default3D, FWGL.Shader.Shader, FWGL.Shader.Language, FWGL.Shader.Default2D, FWGL.Backend.GLES, FWGL.Backend.IO other-modules: FWGL.Internal.STVectorLen, FWGL.Internal.Resource other-extensions: FlexibleContexts, RankNTypes, GADTs, TypeOperators, KindSignatures, DataKinds, MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances, ConstraintKinds, TypeFamilies, ExistentialQuantification, GeneralizedNewtypeDeriving, PolyKinds, UndecidableInstances, ScopedTypeVariables, OverlappingInstances, FunctionalDependencies, DeriveDataTypeable, ImpredicativeTypes, RebindableSyntax, NullaryTypeClasses, Arrows build-depends: base >=4.7 && <4.8, Yampa >=0.9 && <0.10, hashable >=1.2 && <1.3, unordered-containers >=0.2 && <0.3, vector >=0.10 && <0.11, transformers