packages feed

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 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