ixshader (empty) → 0.0.1.0
raw patch · 14 files changed
+1666/−0 lines, 14 filesdep +basedep +ghc-primdep +indexedsetup-changed
Dependencies added: base, ghc-prim, indexed, language-glsl, parsec, prettyclass, singletons, template-haskell, text
Files
- LICENSE +30/−0
- README.md +105/−0
- Setup.hs +2/−0
- ixshader.cabal +52/−0
- src/Graphics/IxShader.hs +262/−0
- src/Graphics/IxShader/Function.hs +87/−0
- src/Graphics/IxShader/Function/ToParams.hs +49/−0
- src/Graphics/IxShader/IxShader.hs +166/−0
- src/Graphics/IxShader/Ops/Mult.hs +118/−0
- src/Graphics/IxShader/Qualifiers.hs +304/−0
- src/Graphics/IxShader/Socket.hs +115/−0
- src/Graphics/IxShader/Swizzle.hs +112/−0
- src/Graphics/IxShader/Types.hs +213/−0
- src/Graphics/IxShader/Types/Xbool.hs +51/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Schell Scivally (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Schell Scivally nor the names of other+ 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.
+ README.md view
@@ -0,0 +1,105 @@+# ixshader+`ixshader` is a shallow embedding of the OpenGL Shading Language in Haskell. It+aims to look as close to actual glsl shader code as possible, while providing+better compile-time safety. Currently writing shader code in `ixshader`'s+`IxShader` monad will catch variable assignment mismatches, multiplication+mismatches and some other common errors. It also builds a description of your+shader at the type level to use downstream during buffering and uniform updates.+Lastly, it abstracts over shader code written for opengl and webgl.++Since this is a work in progress the entire language is not yet supported,+though you can easy use the `nxt` and `acc` functions to push your own glsl into+the pipeline, typechecking only what you want.++The resulting source is pretty and human readable, even debuggable without+sourcemapping.++You should create a separate file for your shaders as `ixshader` relies on+the `RebindableSyntax` language extension and re-defines key functions such as+`>>=`, `>>`, `return`, `fail`, `void`, `fromInteger` and `fromRational`.++## example++```haskell+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module MyShaders where++import Graphics.IxShader++myvertex+ :: forall (ctx :: GLContext). HasContext ctx+ => IxShader ctx '[] '[ In Xvec2 "position"+ , In Xvec4 "color"+ , Uniform Xmat4 "projection"+ , Uniform Xmat4 "modelview"+ , Out Xvec4 "fcolor"+ , Out Xvec4 "gl_Position"+ , Main+ ] ()+myvertex = do+ pos <- in_+ color <- in_+ proj <- uniform_+ modl <- uniform_+ fcolor <- out_+ glPos <- gl_Position+ main_ $ do+ fcolor .= color+ glPos .= proj .* modl .* (pos .: 0.0 .: 1.0)++myfragment+ :: forall (ctx :: GLContext). IsGLContext ctx+ => IxShader ctx '[] '[ In Xvec4 "fcolor"+ , Out Xvec4 (GLFragName ctx)+ , Main+ ] ()+myfragment = do+ fcolor <- in_+ glFrag <- gl_FragColor+ main_ $ glFrag .= fcolor+++main = do+ putStrLn "First OpenGL:"+ putSrcLn $ vertex @'OpenGLContext+ putStrLn "\nThen WebGL:"+ putSrcLn $ vertex @'WebGLContext+{-+First OpenGL:+in vec2 position;+in vec4 color;+uniform mat4 projection;+uniform mat4 modelview;+out vec4 fcolor;+void main ()+{ fcolor = color;+ gl_Position = projection * modelview * vec4 (position.x, position.y, 0.0, 1.0);+}++Then WebGL:+attribute vec2 position;+attribute vec4 color;+uniform mat4 projection;+uniform mat4 modelview;+varying vec4 fcolor;+void main ()+{ fcolor = color;+ gl_Position = projection * modelview * vec4 (position.x, position.y, 0.0, 1.0);+}+-}+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ixshader.cabal view
@@ -0,0 +1,52 @@+name: ixshader+version: 0.0.1.0+synopsis: A shallow embedding of the OpenGL Shading Language in Haskell.+description: ixshader is a shallow embedding of the OpenGL Shading+ Language in Haskell. It aims to look as close to actual+ glsl shader code as possible, while providing better+ compile-time safety. Currently writing shader code in+ ixshader's IxShader monad will catch variable assignment+ mismatches, multiplication mismatches and some other+ common errors. It also builds a description of your shader+ at the type level to use downstream during buffering and+ uniform updates. Lastly, it abstracts over shader code+ written for opengl and webgl.+homepage: https://github.com/schell/ixshader#readme+license: BSD3+license-file: LICENSE+author: Schell Scivally+maintainer: schell@takt.com+copyright: Copyright: (c) 2017 Schell Scivally+category: Game+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ ghc-options: -Wall+ hs-source-dirs: src+ exposed-modules: Graphics.IxShader+ Graphics.IxShader.Function+ Graphics.IxShader.IxShader+ Graphics.IxShader.Ops.Mult+ Graphics.IxShader.Qualifiers+ Graphics.IxShader.Socket+ Graphics.IxShader.Swizzle+ Graphics.IxShader.Types+ Graphics.IxShader.Function.ToParams+ Graphics.IxShader.Types.Xbool++ build-depends: base >= 4.7 && < 5+ , ghc-prim >= 0.5+ , indexed >= 0.1.3+ , language-glsl >= 0.2+ , parsec >= 3.1+ , prettyclass >= 1.0+ , singletons >= 2.2+ , template-haskell >= 2.11.1.0+ , text >= 1.2+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/schell/ixshader
+ src/Graphics/IxShader.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fprint-explicit-kinds #-}+module Graphics.IxShader+ ( module Graphics.IxShader+ , KnownSymbol+ , module G+ , (&&&)+ , module Prelude+ ) where+++import Control.Arrow ((&&&), (>>>))+import Data.List (intercalate)+import Data.Promotion.Prelude.List ((:++))+import Data.Promotion.Prelude.Num+import Data.Proxy+import Data.Ratio (denominator, numerator)+import Data.Singletons.TypeLits+import Graphics.IxShader.Function as G+import Graphics.IxShader.IxShader as G+import Graphics.IxShader.Ops.Mult as G+import Graphics.IxShader.Qualifiers as G+import Graphics.IxShader.Socket as G+import Graphics.IxShader.Swizzle as G+import Graphics.IxShader.Types as G+import Prelude hiding (Eq (..), Floating (..),+ Fractional (..), Num (..),+ Ord (..), fail, fromInteger,+ fromRational, length, log, mod,+ return, (<), (>>), (>>=))+import qualified Prelude as P++fromInteger :: Integer -> Xint+fromInteger = Xint . show++fromRational :: Rational -> Xfloat+fromRational =+ (numerator &&& denominator) >>> \(n, d) ->+ Xfloat $ show (fromIntegral n P./ fromIntegral d :: Float)++infixr 1 .=+(.=)+ :: forall a b i ctx.+ ( Socketed a, Socketed b+ , WriteTo a ~ ReadFrom b+ )+ => a -> b+ -> IxShader ctx i i ()+(.=) a b = nxt_ $ unwords [unSocket a, "=", unSocket b ++ ";"]+++smoothstep :: ( Socketed a, Socketed b, Socketed c+ , Socketed (ReadFrom c)+ , ReadFrom a ~ ReadFrom b+ , ReadFrom a ~ ReadFrom c+ ) => a -> b -> c -> ReadFrom c+smoothstep = call3 "smoothstep"++step :: (Socketed a, Socketed b, Socketed c) => a -> b -> c+step = call2 "step"++mkvec2 :: Xfloat -> Xfloat -> Xvec2+mkvec2 = call2 "vec2"++mkvec3 :: Xfloat -> Xfloat -> Xfloat -> Xvec3+mkvec3 = call3 "vec3"++mkvec4 :: Xfloat -> Xfloat -> Xfloat -> Xfloat -> Xvec4+mkvec4 = call4 "vec4"++mkmat4 :: Xvec4 -> Xvec4 -> Xvec4 -> Xvec4 -> Xmat4+mkmat4 = call4 "mat4"++toInt :: Xfloat -> Xint+toInt = call "int"++toFloat :: Xint -> Xfloat+toFloat = call "float"++float :: Float -> Xfloat+float = Xfloat . show++int :: Int -> Xint+int = Xint . show++type family LengthOf a where+ LengthOf Xfloat = Xfloat+ LengthOf Xvec2 = Xfloat+ LengthOf Xvec3 = Xfloat+ LengthOf Xvec4 = Xfloat+ LengthOf (Uniform t n) = LengthOf t+ LengthOf (In t n) = LengthOf t+ LengthOf (Out t n) = LengthOf t+ LengthOf (Const t) = LengthOf t+ LengthOf a = Error '(a, "Cannot call length on this type.")++length :: (Socketed a, Socketed (LengthOf a)) => a -> LengthOf a+length = call "length"++type family VectOf (n :: Nat) v where+ VectOf 1 Xfloat = Xfloat+ VectOf 2 Xfloat = Xvec2+ VectOf 3 Xfloat = Xvec3+ VectOf 4 Xfloat = Xvec4++ VectOf 2 Xvec2 = Xmat2+ VectOf 3 Xvec2 = Xmat3x2+ VectOf 4 Xvec2 = Xmat4x2++ VectOf 2 Xvec3 = Xmat2x3+ VectOf 3 Xvec3 = Xmat3+ VectOf 4 Xvec3 = Xmat4x3++ VectOf 2 Xvec4 = Xmat4x2+ VectOf 3 Xvec4 = Xmat4x3+ VectOf 4 Xvec4 = Xmat4++type family CompType v where+ CompType Xfloat = Xfloat+ CompType Xvec2 = Xfloat+ CompType Xvec3 = Xfloat+ CompType Xvec4 = Xfloat++ CompType Xmat2 = Xvec2+ CompType Xmat2x3 = Xvec3+ CompType Xmat2x4 = Xvec4++ CompType Xmat3x2 = Xvec2+ CompType Xmat3 = Xvec3+ CompType Xmat3x4 = Xvec4++ CompType Xmat4x2 = Xvec2+ CompType Xmat4x3 = Xvec3+ CompType Xmat4 = Xvec4++type family NumComps v where+ NumComps Xfloat = 1+ NumComps Xvec2 = 2+ NumComps Xvec3 = 3+ NumComps Xvec4 = 4++ NumComps Xmat2 = 2+ NumComps Xmat2x3 = 3+ NumComps Xmat2x4 = 4++ NumComps Xmat3x2 = 2+ NumComps Xmat3 = 3+ NumComps Xmat3x4 = 4++ NumComps Xmat4x2 = 2+ NumComps Xmat4x3 = 3+ NumComps Xmat4 = 4++type family CompCat as bs where+ CompCat as bs = VectOf (NumComps as :+ NumComps bs) (CompType as)++infixr 5 .:+(.:)+ :: forall a b.+ ( KnownTypeSymbol (CompCat (ReadFrom a) (ReadFrom b))+ , Socketed a, Socketed b, Socketed (CompCat (ReadFrom a) (ReadFrom b))+ )+ => a -> b -> CompCat (ReadFrom a) (ReadFrom b)+(.:) = call2 (typeSymbolVal $ Proxy @(CompCat (ReadFrom a) (ReadFrom b)))++type IsGLContext ctx = (HasContext ctx, KnownSymbol (GLFragName ctx))++main_+ :: forall (ctx :: GLContext) i a.+ IxShader ctx i i a -> IxShader ctx i (i :++ '[Main]) ()+main_ f = void $ func @"main" () $ const $ do+ void f+ return nil++infixr 5 +=+(+=) :: Readable a b => a -> b -> ReadFrom a+(+=) = callInfix "+="++infixr 5 -=+(-=) :: Readable a b => a -> b -> ReadFrom a+(-=) = callInfix "-="++mod :: (Socketed a, Socketed b) => a -> b -> a+mod = call2 "mod"++at :: (Socketed a, Socketed (CompType a)) => a -> Xint -> CompType a+at v n = socket $ unSocket v ++ "[" ++ unSocket n ++ "]"++for+ :: (Socketed a, KnownTypeSymbol a)+ => (String, a)+ -> (a -> (Xbool, a))+ -> (a -> IxShader ctx i i b)+ -> IxShader ctx i i b+for (name, v) fi f = do+ let k = socket name+ (itill, iinc) = fi k+ nxt_ $ unwords [ "for ("+ , stringDefinition k v+ , intercalate "; " [ unSocket itill+ , unSocket iinc+ ]+ , ")"+ ]+ sub "{" "}" $ f k++bigfattestvertex+ :: forall (ctx :: GLContext). HasContext ctx+ => IxShader ctx '[] '[ Uniform Xvec2 "u_resolution"+ , Out Xvec4 "gl_Position"+ , Function Xint "myFunc" (Xint, Xint)+ , Main+ ] ()+bigfattestvertex = do+ case getCtx @ctx of+ OpenGLContext -> nxt_ "#version 330 core\n"+ WebGLContext -> nxt_ "precision highp float;\n"+ res <- uniform_+ pos <- gl_Position++ myFunc <- func (Xint "a", Xint "b") $ \(a, b) -> returnValue $ a + b++ main_ $ do+ unless (1 == 1) $ do+ _ <- def "xxx" 1+ _ <- def "yyy" $ length pos+ return ()+ fa <- def "a" 1.0+ fb <- def "b" 2.0+ v4 <- def "v4" $ (fa - fb) .: fb .: mkvec2 3.0 4.0+ v4 .= mkvec2 3.0 4.0 .: fa .: fb+ v4 .= mkvec4 1.0 2.0 3.0 4.0+ xwhy <- def "exwhy" $ fa .: fb+ x xwhy .= 0.0+ xwhy `at` 0 .= 2.0+ xwhy `at` 1 .= 5.0+ m4 <- def "m4" $ mkmat4 v4 v4 v4 v4+ m4 `at` 2 .= mkvec4 0.0 0.0 1.0 0.0+ pa <- def "paramA" 0.0+ pb <- def "paramB" 1.0+ c <- def "c" $ myFunc (toInt pa, toInt pb)+ c .= 5+ c .= toInt (x res)+ x res .= 0.0+ for ("i", 0) ((< 5) &&& (+= 1)) $ \i -> pos .= mkvec4 (toFloat i) 2.0 3.0 4.0
+ src/Graphics/IxShader/Function.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fprint-explicit-kinds #-}+module Graphics.IxShader.Function+ ( module Graphics.IxShader.Function+ , (:++)+ ) where++import Data.List (intercalate)+import Data.Promotion.Prelude+import Data.Singletons.TypeLits+import Prelude hiding (Read, return, (>>),+ (>>=))++import Graphics.IxShader.Function.ToParams+import Graphics.IxShader.IxShader+import Graphics.IxShader.Socket+import Graphics.IxShader.Types (Xvoid)++--------------------------------------------------------------------------------+-- Defining and calling functions+-------------------------------------------------------------------------------+funcReturnType :: forall t ctx i. (KnownTypeSymbol t) => IxShader ctx i i ()+funcReturnType = nxt_ $ typeSymbolVal $ Proxy @t++funcName :: forall name ctx i. (KnownSymbol name) => IxShader ctx i i ()+funcName = nxt_ $ symbolVal $ Proxy @name++funcParams :: ToParams ps => ps -> IxShader ctx i i ()+funcParams ps = nxt_ $ "(" ++ intercalate ", " (toParams ps) ++ ")"++returnValue+ :: (Socketed a, KnownTypeSymbol a)+ => a -> IxShader ctx i i a+returnValue a = nxt (unwords ["return", unSocket a, ";"]) a++funcCall+ :: forall name t ps. (KnownSymbol name, Socketed t, ToParams ps)+ => ps+ -> t+funcCall ps = socket $ unwords [ symbolVal $ Proxy @name+ , "("+ , intercalate ", " $ toNames ps+ , ")"+ ]++data Function rtype fname ps = Function++type IxFunction ctx i rtype fname ps =+ IxShader ctx i (i :++ '[Function rtype fname ps]) (ps -> rtype)++func+ :: forall fname rtype ps ctx i.+ (ToParams ps, KnownTypeSymbol rtype, Socketed rtype, KnownSymbol fname)+ => ps+ -> (ps -> IxShader ctx i i rtype)+ -> IxShader ctx i (i :++ '[Function rtype fname ps]) (ps -> rtype)+func ps f = do+ nxt_ ""+ funcReturnType @rtype+ funcName @fname+ funcParams ps+ sub_ "{" "}" $ f ps+ acc "" (Function @rtype @fname @ps) ()+ nxt_ ""+ return $ funcCall @fname++use :: Socketed a => a -> IxShader ctx i i ()+use a = nxt_ (unSocket a ++ ";")++type Main = Function Xvoid "main" ()
+ src/Graphics/IxShader/Function/ToParams.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fprint-explicit-kinds #-}+module Graphics.IxShader.Function.ToParams where++import Language.Haskell.TH+import Graphics.IxShader.Socket+--------------------------------------------------------------------------------+-- Abstracting over function parameters.+--------------------------------------------------------------------------------+class ToParams a where+ toParams :: a -> [String]++instance ToParams () where+ toParams () = []++genToParams :: TypeQ -> DecsQ+genToParams t = [d|+ instance (Socketed $t, KnownTypeSymbol $t) => ToParams $t where+ toParams a = [toDefinition a]+ |]++instance (ToParams a, ToParams b) => ToParams (a, b) where+ toParams (a, b) = toParams a ++ toParams b++instance (ToParams a, ToParams b, ToParams c) => ToParams (a, b, c) where+ toParams (a, b, c) = toParams a ++ toParams b ++ toParams c++instance (ToParams a, ToParams b, ToParams c, ToParams d) => ToParams (a, b, c, d) where+ toParams (a, b, c, d) = toParams a ++ toParams b ++ toParams c ++ toParams d++toNames :: ToParams ps => ps -> [String]+toNames = map (drop 1 . dropWhile (/= ' ')) . toParams
+ src/Graphics/IxShader/IxShader.hs view
@@ -0,0 +1,166 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fprint-explicit-kinds #-}+module Graphics.IxShader.IxShader+ ( IxShader+ , unDecl+ , unN+ , (>>=)+ , (>>)+ , return+ , fail+ , void+ , acc+ , nxt+ , nxt_+ , sub+ , sub_+ , pop+ , putSrcLn+ , onlySrc+ , toSrc+ , ixShaderSrc+ ) where++import Control.Arrow ((&&&))+import Control.Monad.Indexed+import Data.Promotion.Prelude.List ((:++))+import Data.List (isSuffixOf)+import Language.GLSL (TranslationUnit (..), parse)+import Prelude hiding (Read, return, (>>),+ (>>=), fail)+import Text.PrettyPrint.HughesPJClass hiding (int)+++data IxShader ctx i j n where+ ShNxt :: [String] -> n -> IxShader ctx i j n+ ShAcc :: [String] -> t -> n -> IxShader ctx i (i :++ '[t]) n+ ShPop :: n -> IxShader ctx (t ': j) j n++unN :: IxShader ctx i j n -> n+unN = \case+ ShNxt _ n -> n+ ShAcc _ _ n -> n+ ShPop n -> n++unDecl :: IxShader ctx i j n -> [String]+unDecl = \case+ ShNxt d _ -> d+ ShAcc d _ _ -> d+ ShPop _ -> []++instance IxFunctor (IxShader ctx) where+ imap f sh = ShNxt (unDecl sh) $ f (unN sh)++instance IxPointed (IxShader ctx) where+ ireturn = ShNxt []++instance IxApplicative (IxShader ctx) where+ iap mf mx = ShNxt (unDecl mf ++ unDecl mx) $ unN mf $ unN mx++instance IxMonad (IxShader ctx) where+ ibind amb ma =+ let (dsa, a) = unDecl &&& unN $ ma+ (dsb, b) = unDecl &&& unN $ amb a+ in ShNxt (dsa ++ dsb) b++fail :: forall i j a ctx. String -> IxShader ctx i j a+fail = error++(>>=) :: forall i j k a b ctx. IxShader ctx i j a -> (a -> IxShader ctx j k b) -> IxShader ctx i k b+a >>= b = a >>>= b++return :: forall a i ctx. a -> IxShader ctx i i a+return = ireturn++(>>) :: forall i j a k b ctx. IxShader ctx i j a -> IxShader ctx j k b -> IxShader ctx i k b+a >> b = a >>>= const b++void :: IxShader ctx i k a -> IxShader ctx i k ()+void ma = ma >> return ()++-- | Does three things - appends a type to the IxMonad @j@, encodes one or more+-- lines of shader code and returns something. This is the main entry point for+-- any shader building code, and also an easy escape hatch.+acc+ :: forall typ a i ctx. String+ -> typ+ -> a+ -> IxShader ctx i (i :++ '[typ]) a+acc dec = ShAcc (lines dec)++nxt+ :: forall i a ctx.+ String+ -> a+ -> IxShader ctx i i a+nxt dec = ShNxt (lines dec)++nxt_ :: forall i ctx. String -> IxShader ctx i i ()+nxt_ dec = nxt dec ()++sub+ :: forall i j a ctx.+ String+ -> String+ -> IxShader ctx i j a+ -> IxShader ctx i j a+sub open close sh = do+ nxt open ()+ a <- sh+ nxt close ()+ return a++sub_+ :: forall i j a ctx.+ String+ -> String+ -> IxShader ctx i j a+ -> IxShader ctx i j ()+sub_ open close sh = sub open close sh >> return ()++pop+ :: IxShader ctx (t ': j) j ()+pop = ShPop ()++--------------------------------------------------------------------------------+-- From IxShader to GLSL+--------------------------------------------------------------------------------+fromIxShader :: IxShader ctx '[] j a -> Either String TranslationUnit+fromIxShader = showLeft . parse . unlines . unDecl+ where showLeft = \case+ Left err -> Left $ show err+ Right ast -> Right ast++toSrc :: Pretty a => a -> String+toSrc = show . pPrint++onlySrc :: IxShader ctx i j a -> String+onlySrc = unlines . snd . foldl indent (0, []) . unDecl+ where ndnt = " "+ incIndent n ln+ | "{" `isSuffixOf` ln = n + 1+ | "}" `isSuffixOf` ln = n - 1+ | otherwise = n+ indent (n, decls) ln = (incIndent n ln, decls ++ [concat (replicate n ndnt) ++ ln])++ixShaderSrc :: IxShader ctx '[] j a -> Either String String+ixShaderSrc = fmap toSrc . fromIxShader++putSrcLn :: forall ctx j a. IxShader ctx '[] j a -> IO ()+putSrcLn = either putStrLn (putStrLn . toSrc) . fromIxShader
+ src/Graphics/IxShader/Ops/Mult.hs view
@@ -0,0 +1,118 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fprint-explicit-kinds #-}+module Graphics.IxShader.Ops.Mult where++import Prelude hiding (Read, return, (>>), (>>=))++import Graphics.IxShader.Socket+import Graphics.IxShader.Types+import Graphics.IxShader.Qualifiers+++type family MatFromColRow a b where+ MatFromColRow 2 2 = Xmat2+ MatFromColRow 2 3 = Xmat2x3+ MatFromColRow 2 4 = Xmat2x4+ MatFromColRow 3 3 = Xmat3+ MatFromColRow 3 2 = Xmat3x2+ MatFromColRow 3 4 = Xmat3x4+ MatFromColRow 4 4 = Xmat4+ MatFromColRow 4 2 = Xmat4x2+ MatFromColRow 4 3 = Xmat4x3++type family MatCol a where+ MatCol Xvec2 = 2+ MatCol Xvec3 = 3+ MatCol Xvec4 = 4+ MatCol Xmat2 = 2+ MatCol Xmat2x3 = 2+ MatCol Xmat2x4 = 2+ MatCol Xmat3 = 3+ MatCol Xmat3x2 = 3+ MatCol Xmat3x4 = 3+ MatCol Xmat4 = 4+ MatCol Xmat4x2 = 4+ MatCol Xmat4x3 = 4++type family MatRow a where+ MatRow Xvec2 = 1+ MatRow Xvec3 = 1+ MatRow Xvec4 = 1+ MatRow Xmat2 = 2+ MatRow Xmat2x3 = 2+ MatRow Xmat2x4 = 2+ MatRow Xmat3 = 3+ MatRow Xmat3x2 = 3+ MatRow Xmat3x4 = 3+ MatRow Xmat4 = 4+ MatRow Xmat4x2 = 4+ MatRow Xmat4x3 = 4++type family FromMatColRow ac ar at bc br bt where+ FromMatColRow _ 1 a _ _ b = a+ FromMatColRow _ _ a _ 1 b = b+ FromMatColRow c _ _ _ r _ = MatFromColRow c r++type family Multiply a b where+ Multiply Xfloat Xvec2 = Xvec2+ Multiply Xfloat Xvec3 = Xvec3+ Multiply Xfloat Xvec4 = Xvec4+ Multiply Xfloat Xmat2 = Xmat2+ Multiply Xfloat Xmat2x3 = Xmat2x3+ Multiply Xfloat Xmat2x4 = Xmat2x4+ Multiply Xfloat Xmat3x2 = Xmat3x2+ Multiply Xfloat Xmat3 = Xmat3+ Multiply Xfloat Xmat3x4 = Xmat3x4+ Multiply Xfloat Xmat4x2 = Xmat4x2+ Multiply Xfloat Xmat4x3 = Xmat4x3+ Multiply Xfloat Xmat4 = Xmat4++ Multiply Xvec2 Xfloat = Xvec2+ Multiply Xvec3 Xfloat = Xvec3+ Multiply Xvec4 Xfloat = Xvec4+ Multiply Xmat2 Xfloat = Xmat2+ Multiply Xmat2x3 Xfloat = Xmat2x3+ Multiply Xmat2x4 Xfloat = Xmat2x4+ Multiply Xmat3x2 Xfloat = Xmat3x2+ Multiply Xmat3 Xfloat = Xmat3+ Multiply Xmat3x4 Xfloat = Xmat3x4+ Multiply Xmat4x2 Xfloat = Xmat4x2+ Multiply Xmat4x3 Xfloat = Xmat4x3+ Multiply Xmat4 Xfloat = Xmat4++ Multiply Xuint Xuvec2 = Xuvec2+ Multiply Xuint Xuvec3 = Xuvec3+ Multiply Xuint Xuvec4 = Xuvec4+ Multiply a Xuint = Multiply Xuint a++ Multiply Xint Xivec2 = Xivec2+ Multiply Xint Xivec3 = Xivec3+ Multiply Xint Xivec4 = Xivec4+ Multiply a Xint = Multiply Xint a++ Multiply a b = FromMatColRow (MatCol a) (MatRow a) a (MatCol b) (MatRow b) b++-- | Multiply two sockets.+infixl 7 .*+(.*)+ :: forall a b. (Socketed a, Socketed b, Socketed (Multiply (ReadFrom a) (ReadFrom b)))+ => a+ -> b+ -> Multiply (ReadFrom a) (ReadFrom b)+(.*) = callInfix "*"
+ src/Graphics/IxShader/Qualifiers.hs view
@@ -0,0 +1,304 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fprint-explicit-kinds #-}+module Graphics.IxShader.Qualifiers where+++import Data.Promotion.Prelude hiding (Const)+import Data.Singletons.TypeLits+import Prelude hiding (Read, return, (>>),+ (>>=), log)++import Graphics.IxShader.Function+import Graphics.IxShader.IxShader+import Graphics.IxShader.Types++newtype Uniform typ name = Uniform { unUniform :: typ }++instance KnownTypeSymbol t => KnownTypeSymbol (Uniform t n) where+ typeSymbolVal _ = typeSymbolVal $ Proxy @t++instance Socketed t => Socketed (Uniform t n) where+ unSocket = unSocket . unUniform+ socket = Uniform . socket++newtype In typ name = In { unIn :: typ }++instance KnownTypeSymbol t => KnownTypeSymbol (In t n) where+ typeSymbolVal _ = typeSymbolVal $ Proxy @t++instance Socketed t => Socketed (In t n) where+ unSocket = unSocket . unIn+ socket = In . socket++newtype Out typ name = Out { unOut :: typ }++instance KnownTypeSymbol t => KnownTypeSymbol (Out t n) where+ typeSymbolVal _ = typeSymbolVal $ Proxy @t++instance Socketed t => Socketed (Out t n) where+ unSocket = unSocket . unOut+ socket = Out . socket++newtype Const typ = Const { unConst :: typ }++instance KnownTypeSymbol t => KnownTypeSymbol (Const t) where+ typeSymbolVal _ = typeSymbolVal $ Proxy @t++instance Socketed t => Socketed (Const t) where+ unSocket = unSocket . unConst+ socket = Const . socket++-- Read and write rules+type family ReadFrom a where+ ReadFrom (Uniform t n) = t+ ReadFrom (In t n) = t+ ReadFrom (Out t n) = Error '(Out t n, "Cannot be read.")+ ReadFrom (Const t) = t+ ReadFrom t = t++type family WriteTo a where+ WriteTo (Uniform t n) = Error '(Uniform t n, "Cannot be written.")+ WriteTo (In t n) = Error '(In t n, "Cannot be written.")+ WriteTo (Out t n) = t+ WriteTo (Const t) = Error '(Const t, "Cannot be written.")+ WriteTo t = t++class Cast a b where+ cast :: a -> b++instance (Socketed a, Socketed (ReadFrom a), b ~ ReadFrom a) => Cast a b where+ cast = socket . unSocket++type Readable a b = ( Socketed (ReadFrom a), Socketed a, Socketed b+ , ReadFrom a ~ ReadFrom b+ )++infixl 6 ++(+) :: Readable a b => a -> b -> ReadFrom a+(+) = callInfix "+"++infixl 6 -+(-) :: Readable a b => a -> b -> ReadFrom a+(-) = callInfix "-"++infixl 7 *+(*) :: Readable a b => a -> b -> ReadFrom a+(*) = callInfix "*"++negate :: (Socketed a, Socketed (ReadFrom a)) => a -> ReadFrom a+negate a = socket $ concat ["(-", unSocket a, ")"]++abs :: (Socketed a, Socketed (ReadFrom a)) => a -> ReadFrom a+abs = call "abs"++signum :: (Socketed a, Socketed (ReadFrom a)) => a -> ReadFrom a+signum = call "sign"++infixl 7 /+(/) :: Readable a b => a -> b -> ReadFrom a+(/) = callInfix "/"++exp :: (Socketed a, Socketed (ReadFrom a)) => a -> ReadFrom a+exp = call "exp"++log :: (Socketed a, Socketed (ReadFrom a)) => a -> ReadFrom a+log = call "log"++sqrt :: (Socketed a, Socketed (ReadFrom a)) => a -> ReadFrom a+sqrt = call "sqrt"++(**):: Readable a b => a -> b -> ReadFrom a+(**) = call2 "pow"++logBase :: Readable a b => a -> b -> ReadFrom a+logBase a b = callInfix "/" (log b) (log a)++sin :: (Socketed a, Socketed (ReadFrom a)) => a -> ReadFrom a+sin = call "sin"++cos :: (Socketed a, Socketed (ReadFrom a)) => a -> ReadFrom a+cos = call "cos"++tan :: (Socketed a, Socketed (ReadFrom a)) => a -> ReadFrom a+tan = call "tan"++asin :: (Socketed a, Socketed (ReadFrom a)) => a -> ReadFrom a+asin = call "asin"++acos :: (Socketed a, Socketed (ReadFrom a)) => a -> ReadFrom a+acos = call "acos"++atan :: (Socketed a, Socketed (ReadFrom a)) => a -> ReadFrom a+atan = call "atan"++sinh :: (Socketed a, Socketed (ReadFrom a)) => a -> ReadFrom a+sinh = call "sinh"++cosh :: (Socketed a, Socketed (ReadFrom a)) => a -> ReadFrom a+cosh = call "cosh"++tanh :: (Socketed a, Socketed (ReadFrom a)) => a -> ReadFrom a+tanh = call "tanh"++asinh :: (Socketed a, Socketed (ReadFrom a)) => a -> ReadFrom a+asinh = call "asinh"++acosh :: (Socketed a, Socketed (ReadFrom a)) => a -> ReadFrom a+acosh = call "acosh"++atanh :: (Socketed a, Socketed (ReadFrom a)) => a -> ReadFrom a+atanh = call "atanh"++infix 4 ==+(==) :: Readable a b => a -> b -> Xbool+(==) = callInfix "=="++infix 4 /=+(/=) :: Readable a b => a -> b -> Xbool+(/=) = callInfix "!="++infix 4 <+(<) :: Readable a b => a -> b -> Xbool+(<) = callInfix "<"++infix 4 <=+(<=) :: Readable a b => a -> b -> Xbool+(<=) = callInfix "<="++infix 4 >+(>) :: Readable a b => a -> b -> Xbool+(>) = callInfix ">"++infix 4 >=+(>=) :: Readable a b => a -> b -> Xbool+(>=) = callInfix ">="++max :: Readable a b => a -> b -> ReadFrom a+max = call2 "max"++min :: Readable a b => a -> b -> ReadFrom a+min = call2 "min"++normalize :: (Socketed a, Socketed (ReadFrom a)) => a -> ReadFrom a+normalize = call "normalize"++dot :: Readable a b => a -> b -> Xfloat+dot = call2 "dot"++--------------------------------------------------------------------------------+-- Program-level in/out bindings+--------------------------------------------------------------------------------+class Binding a t where+ getVertexBinding :: t+ getUniformBinding :: t++instance KnownSymbol b => Binding (Uniform a b) (Maybe String) where+ getVertexBinding = Nothing+ getUniformBinding = Just $ symbolVal $ Proxy @b++instance KnownSymbol b => Binding (In a b) (Maybe String) where+ getVertexBinding = Just $ symbolVal $ Proxy @b+ getUniformBinding = Nothing++instance Binding (Out a b) (Maybe String) where+ getVertexBinding = Nothing+ getUniformBinding = Nothing++instance Binding (Function a b c) (Maybe String) where+ getVertexBinding = Nothing+ getUniformBinding = Nothing++instance Binding '[] [t] where+ getVertexBinding = []+ getUniformBinding = []++instance (Binding a t, Binding as [t]) => Binding (a ': as) [t] where+ getVertexBinding = getVertexBinding @a : getVertexBinding @as+ getUniformBinding = getUniformBinding @a : getUniformBinding @as++-- | Some glsl evaluation contexts. This is used to choose alternate syntax in+-- cases where shader code differs between contexts, for example the @in@ keyword+-- is not available on glsl bound for a webgl context, and should be replaced+-- with @attribute@.+data GLContext = OpenGLContext | WebGLContext++-- | An easy way to get the term level value of a type of kind 'GLContext'.+class HasContext (a :: GLContext) where+ getCtx :: GLContext+instance HasContext 'OpenGLContext where+ getCtx = OpenGLContext+instance HasContext 'WebGLContext where+ getCtx = WebGLContext++uniform_+ :: forall t name ts ctx. (KnownSymbol name, Socketed t, KnownTypeSymbol t)+ => IxShader ctx ts (ts :++ '[Uniform t name]) (Uniform t name)+uniform_ = acc decls u u+ where+ u = socket $ symbolVal $ Proxy @name+ decls = unwords ["uniform", toDefinition u, ";"]++in_+ :: forall t name ts ctx.+ (HasContext ctx, KnownSymbol name, Socketed t, KnownTypeSymbol t)+ => IxShader ctx ts (ts :++ '[In t name]) (In t name)+in_ = acc decls i i+ where+ i = socket $ symbolVal $ Proxy @name+ dec = case getCtx @ctx of+ OpenGLContext -> "in"+ WebGLContext -> "attribute"+ decls = unwords [dec, toDefinition i, ";"]++out_+ :: forall t name ts ctx.+ (HasContext ctx, KnownSymbol name, Socketed t, KnownTypeSymbol t)+ => IxShader ctx ts (ts :++ '[Out t name]) (Out t name)+out_ = acc decls o o+ where+ o = socket $ symbolVal $ Proxy @name+ dec = case getCtx @ctx of+ OpenGLContext -> "out"+ WebGLContext -> "varying"+ decls = unwords [dec, toDefinition o, ";"]++gl_Position+ :: forall ts ctx.+ IxShader ctx ts (ts :++ '[Out Xvec4 "gl_Position"]) (Out Xvec4 "gl_Position")+gl_Position = acc [] o o+ where o = socket "gl_Position"++type family GLFragName (a :: GLContext) where+ GLFragName 'OpenGLContext = "fragColor"+ GLFragName 'WebGLContext = "gl_FragColor"++gl_FragColor+ :: forall ctx ts. (HasContext ctx, KnownSymbol (GLFragName ctx))+ => IxShader ctx ts (ts :++ '[Out Xvec4 (GLFragName ctx)]) (Out Xvec4 (GLFragName ctx))+gl_FragColor = acc decls o o+ where o = socket $ symbolVal $ Proxy @(GLFragName ctx)+ decls = case getCtx @ctx of+ OpenGLContext -> unwords ["out", toDefinition o, ";"]+ _ -> []++gl_FragCoord :: Xvec4+gl_FragCoord = Xvec4 "gl_FragCoord"
+ src/Graphics/IxShader/Socket.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fprint-explicit-kinds #-}+module Graphics.IxShader.Socket where+++import Data.List (intercalate)+import Data.Promotion.Prelude++import Graphics.IxShader.IxShader+import Language.Haskell.TH+import Prelude hiding (return, (>>), (>>=))++class KnownTypeSymbol a where+ typeSymbolVal :: Proxy a -> String++genKnownTypeSymbol :: TypeQ -> ExpQ -> DecsQ+genKnownTypeSymbol t s = [d|+ instance KnownTypeSymbol $t where+ typeSymbolVal _ = $s+ |]++-- | A socket is simply a place where you can stick an external expression+-- as a string. It's good for named uninitializeds, function application, all sorts of+-- stuff.+class Socketed a where+ unSocket :: a -> String+ socket :: String -> a++genSocketed :: TypeQ -> ExpQ -> ExpQ -> DecsQ+genSocketed t un con = [d|+ instance Socketed $t where+ unSocket = $un+ socket = $con+ |]++call+ :: (Socketed a, Socketed b)+ => String+ -> a -> b+call fncstr a = socket $ concat [fncstr, "(", unSocket a, ")"]++call2+ :: (Socketed a, Socketed b, Socketed c)+ => String+ -> a -> b -> c+call2 fncstr a b =+ socket $ concat [fncstr, "(", unSocket a, ",", unSocket b, ")"]++call3+ :: (Socketed a, Socketed b, Socketed c, Socketed d)+ => String+ -> a -> b -> c -> d+call3 fncstr a b c =+ socket $ concat [fncstr, "(", unSocket a, ",", unSocket b, ",", unSocket c, ")"]++call4+ :: (Socketed a, Socketed b, Socketed c, Socketed d, Socketed e)+ => String+ -> a -> b -> c -> d -> e+call4 fncstr a b c d = socket $ concat [fncstr, "(", params, ")"]+ where params = intercalate "," [unSocket a, unSocket b, unSocket c, unSocket d]++callInfix+ :: (Socketed a, Socketed b, Socketed c)+ => String+ -> a -> b -> c+callInfix fncstr a b =+ socket $ concat ["(", unSocket a, fncstr, unSocket b, ")"]++toDefinition :: forall a. (Socketed a, KnownTypeSymbol a) => a -> String+toDefinition a = unwords [typeSymbolVal $ Proxy @a, unSocket a]++-- | Construct a new thing. Declares the thing w/o initialization.+define+ :: (Socketed a, KnownTypeSymbol a)+ => a+ -> IxShader ctx i i a+define a = nxt (toDefinition a ++ ";") a++stringDefinition :: (Socketed k, KnownTypeSymbol k) => k -> k -> String+stringDefinition k v = toDefinition k ++ " = " ++ unSocket v ++ ";"++-- | Construct a new assignable thing. Initializes it with another thing.+defineAs+ :: (Socketed a, KnownTypeSymbol a)+ => String+ -> a+ -> IxShader ctx i i a+defineAs s v =+ let k = socket s in nxt (stringDefinition k v) k++def+ :: (Socketed a, KnownTypeSymbol a)+ => String+ -> a+ -> IxShader ctx i i a+def = defineAs
+ src/Graphics/IxShader/Swizzle.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fprint-explicit-kinds #-}+module Graphics.IxShader.Swizzle+ ( Swizzled+ , swizzle+ , x+ , y+ , z+ , xy+ , xz+ , yz+ , xyz+ ) where++import Data.Proxy (Proxy (..))+import Data.Singletons.TypeLits+import Prelude hiding (Read, return, (>>), (>>=))+++import Graphics.IxShader.Socket as G+import Graphics.IxShader.Qualifiers as G+import Graphics.IxShader.Types as G++type family Swizzled a b where+ Swizzled 1 Xvec2 = Xfloat+ Swizzled 1 Xvec3 = Xfloat+ Swizzled 1 Xvec4 = Xfloat+ Swizzled 2 Xvec2 = Xvec2+ Swizzled 2 Xvec3 = Xvec2+ Swizzled 2 Xvec4 = Xvec2+ Swizzled 3 Xvec2 = Error "Swizzled error: vector field selection out of range"+ Swizzled 3 Xvec3 = Xvec3+ Swizzled 3 Xvec4 = Xvec3+ Swizzled 4 Xvec2 = Error "Swizzled error: vector field selection out of range"+ Swizzled 4 Xvec3 = Error "Swizzled error: vector field selection out of range"+ Swizzled 4 Xvec4 = Xvec4++type SwizzleRead a n =+ (Socketed a, Socketed (ReadFrom a), Socketed (Swizzled n (ReadFrom a)))++swizzle+ :: forall (n :: Nat) a.+ ( SwizzleRead a n+ , KnownNat n+ )+ => String+ -> a+ -> Swizzled n (ReadFrom a)+swizzle s a = socket $ concat ["("+ , unSocket a+ , ")." ++ take (fromIntegral $ natVal $ Proxy @n) s+ ]++x :: forall a.+ SwizzleRead a 1+ => a+ -> Swizzled 1 (ReadFrom a)+x = swizzle @1 "x"++y :: forall a.+ SwizzleRead a 1+ => a+ -> Swizzled 1 (ReadFrom a)+y = swizzle @1 "y"++z :: forall a.+ SwizzleRead a 1+ => a+ -> Swizzled 1 (ReadFrom a)+z = swizzle @1 "z"++xy :: forall a.+ SwizzleRead a 2+ => a+ -> Swizzled 2 (ReadFrom a)+xy = swizzle @2 "xy"++xz :: forall a.+ SwizzleRead a 2+ => a+ -> Swizzled 2 (ReadFrom a)+xz = swizzle @2 "xz"++yz :: forall a.+ SwizzleRead a 2+ => a+ -> Swizzled 2 (ReadFrom a)+yz = swizzle @2 "yz"++xyz :: forall a.+ SwizzleRead a 3+ => a+ -> Swizzled 3 (ReadFrom a)+xyz = swizzle @3 "xyz"
+ src/Graphics/IxShader/Types.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fprint-explicit-kinds #-}+module Graphics.IxShader.Types+ ( module Graphics.IxShader.Types+ , module G+ ) where+++import Prelude hiding (Ord (..), Read, return,+ (>>), (>>=))++import Graphics.IxShader.Socket as G+import Graphics.IxShader.Types.Xbool as G+import Graphics.IxShader.Function.ToParams++--------------------------------------------------------------------------------+-- int, uint, float+--------------------------------------------------------------------------------+newtype Xvoid = Xvoid { unXvoid :: String }+instance Socketed Xvoid where+ unSocket = unXvoid+ socket = Xvoid+instance KnownTypeSymbol Xvoid where+ typeSymbolVal _ = "void"++nil :: Xvoid+nil = Xvoid ""++--------------------------------------------------------------------------------+-- int, uint, float+--------------------------------------------------------------------------------+newtype Xint = Xint { unXint :: String }+$(genKnownTypeSymbol [t|Xint|] [e|"int"|])+$(genSocketed [t|Xint|] [e|unXint|] [e|Xint|])+$(genToParams [t|Xint|])++--int :: Int -> Xint+--int = Xint . show++newtype Xuint = Xuint { unXuint :: String }+$(genKnownTypeSymbol [t|Xuint|] [e|"uint"|])+$(genSocketed [t|Xuint|] [e|unXuint|] [e|Xuint|])+$(genToParams [t|Xuint|])++--uint :: Word -> Xuint+--uint = Xuint . show++newtype Xfloat = Xfloat { unXfloat :: String }+$(genKnownTypeSymbol [t|Xfloat|] [e|"float"|])+$(genSocketed [t|Xfloat|] [e|unXfloat|] [e|Xfloat|])+$(genToParams [t|Xfloat|])+++pi :: Socketed a => a+pi = socket $ show (Prelude.pi :: Float)++--float :: Float -> Xfloat+--float = Xfloat . show++--------------------------------------------------------------------------------+-- vec[2,3,4]+--------------------------------------------------------------------------------+newtype Xvec2 = Xvec2 { unXvec2 :: String }+$(genKnownTypeSymbol [t|Xvec2|] [e|"vec2"|])+$(genSocketed [t|Xvec2|] [e|unXvec2|] [e|Xvec2|])+$(genToParams [t|Xvec2|])++--vec2 :: Float -> Float -> Xvec2+--vec2++newtype Xvec3 = Xvec3 { unXvec3 :: String }+$(genKnownTypeSymbol [t|Xvec3|] [e|"vec3"|])+$(genSocketed [t|Xvec3|] [e|unXvec3|] [e|Xvec3|])+$(genToParams [t|Xvec3|])++newtype Xvec4 = Xvec4 { unXvec4 :: String }+$(genKnownTypeSymbol [t|Xvec4|] [e|"vec4"|])+$(genSocketed [t|Xvec4|] [e|unXvec4|] [e|Xvec4|])+$(genToParams [t|Xvec4|])+++--------------------------------------------------------------------------------+-- bvec[2,3,4]+--------------------------------------------------------------------------------+newtype Xbvec2 = Xbvec2 { unXbvec2 :: String }+$(genKnownTypeSymbol [t|Xbvec2|] [e|"bvec2"|])+$(genSocketed [t|Xbvec2|] [e|unXbvec2|] [e|Xbvec2|])+$(genToParams [t|Xbvec2|])++newtype Xbvec3 = Xbvec3 { unXbvec3 :: String }+$(genKnownTypeSymbol [t|Xbvec3|] [e|"bvec3"|])+$(genSocketed [t|Xbvec3|] [e|unXbvec3|] [e|Xbvec3|])+$(genToParams [t|Xbvec3|])++newtype Xbvec4 = Xbvec4 { unXbvec4 :: String }+$(genKnownTypeSymbol [t|Xbvec4|] [e|"bvec4"|])+$(genSocketed [t|Xbvec4|] [e|unXbvec4|] [e|Xbvec4|])+$(genToParams [t|Xbvec4|])+++--------------------------------------------------------------------------------+-- ivec[2,3,4]+--------------------------------------------------------------------------------+newtype Xivec2 = Xivec2 { unXivec2 :: String }+$(genKnownTypeSymbol [t|Xivec2|] [e|"ivec2"|])+$(genSocketed [t|Xivec2|] [e|unXivec2|] [e|Xivec2|])+$(genToParams [t|Xivec2|])++newtype Xivec3 = Xivec3 { unXivec3 :: String }+$(genKnownTypeSymbol [t|Xivec3|] [e|"ivec3"|])+$(genSocketed [t|Xivec3|] [e|unXivec3|] [e|Xivec3|])+$(genToParams [t|Xivec3|])++newtype Xivec4 = Xivec4 { unXivec4 :: String }+$(genKnownTypeSymbol [t|Xivec4|] [e|"ivec4"|])+$(genSocketed [t|Xivec4|] [e|unXivec4|] [e|Xivec4|])+$(genToParams [t|Xivec4|])+++--------------------------------------------------------------------------------+-- uvec[2,3,4]+--------------------------------------------------------------------------------+newtype Xuvec2 = Xuvec2 { unXuvec2 :: String }+$(genKnownTypeSymbol [t|Xuvec2|] [e|"uvec2"|])+$(genSocketed [t|Xuvec2|] [e|unXuvec2|] [e|Xuvec2|])+$(genToParams [t|Xuvec2|])++newtype Xuvec3 = Xuvec3 { unXuvec3 :: String }+$(genKnownTypeSymbol [t|Xuvec3|] [e|"uvec3"|])+$(genSocketed [t|Xuvec3|] [e|unXuvec3|] [e|Xuvec3|])+$(genToParams [t|Xuvec3|])++newtype Xuvec4 = Xuvec4 { unXuvec4 :: String }+$(genKnownTypeSymbol [t|Xuvec4|] [e|"uvec4"|])+$(genSocketed [t|Xuvec4|] [e|unXuvec4|] [e|Xuvec4|])+$(genToParams [t|Xuvec4|])+++--------------------------------------------------------------------------------+-- mat2x[2,3,4]+--------------------------------------------------------------------------------+newtype Xmat2 = Xmat2 { unXmat2 :: String }+$(genKnownTypeSymbol [t|Xmat2|] [e|"mat2"|])+$(genSocketed [t|Xmat2|] [e|unXmat2|] [e|Xmat2|])+$(genToParams [t|Xmat2|])+type Xmat2x2 = Xmat2++newtype Xmat2x3 = Xmat2x3 { unXmat2x3 :: String }+$(genKnownTypeSymbol [t|Xmat2x3|] [e|"mat2x3"|])+$(genSocketed [t|Xmat2x3|] [e|unXmat2x3|] [e|Xmat2x3|])+$(genToParams [t|Xmat2x3|])++newtype Xmat2x4 = Xmat2x4 { unXmat2x4 :: String }+$(genKnownTypeSymbol [t|Xmat2x4|] [e|"mat2x4"|])+$(genSocketed [t|Xmat2x4|] [e|unXmat2x4|] [e|Xmat2x4|])+$(genToParams [t|Xmat2x4|])+++--------------------------------------------------------------------------------+-- mat3x[2,3,4]+--------------------------------------------------------------------------------+newtype Xmat3x2 = Xmat3x2 { unXmat3x2 :: String }+$(genKnownTypeSymbol [t|Xmat3x2|] [e|"mat3x2"|])+$(genSocketed [t|Xmat3x2|] [e|unXmat3x2|] [e|Xmat3x2|])+$(genToParams [t|Xmat3x2|])++newtype Xmat3 = Xmat3 { unXmat3 :: String }+$(genKnownTypeSymbol [t|Xmat3|] [e|"mat3"|])+$(genSocketed [t|Xmat3|] [e|unXmat3|] [e|Xmat3|])+$(genToParams [t|Xmat3|])+type Xmat3x3 = Xmat3++newtype Xmat3x4 = Xmat3x4 { unXmat3x4 :: String }+$(genKnownTypeSymbol [t|Xmat3x4|] [e|"mat3x4"|])+$(genSocketed [t|Xmat3x4|] [e|unXmat3x4|] [e|Xmat3x4|])+$(genToParams [t|Xmat3x4|])++--------------------------------------------------------------------------------+-- mat4x[2,3,4]+--------------------------------------------------------------------------------+newtype Xmat4x2 = Xmat4x2 { unXmat4x2 :: String }+$(genKnownTypeSymbol [t|Xmat4x2|] [e|"mat4x2"|])+$(genSocketed [t|Xmat4x2|] [e|unXmat4x2|] [e|Xmat4x2|])+$(genToParams [t|Xmat4x2|])++newtype Xmat4x3 = Xmat4x3 { unXmat4x3 :: String }+$(genKnownTypeSymbol [t|Xmat4x3|] [e|"mat4x3"|])+$(genSocketed [t|Xmat4x3|] [e|unXmat4x3|] [e|Xmat4x3|])+$(genToParams [t|Xmat4x3|])++newtype Xmat4 = Xmat4 { unXmat4 :: String }+$(genKnownTypeSymbol [t|Xmat4|] [e|"mat4"|])+$(genSocketed [t|Xmat4|] [e|unXmat4|] [e|Xmat4|])+$(genToParams [t|Xmat4|])+type Xmat4x4 = Xmat4
+ src/Graphics/IxShader/Types/Xbool.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fprint-explicit-kinds #-}+module Graphics.IxShader.Types.Xbool where+++import Prelude hiding (Ord (..), Read, return, (>>),+ (>>=), Eq (..))++import Graphics.IxShader.Socket+import Graphics.IxShader.Function.ToParams+import Graphics.IxShader.IxShader+++newtype Xbool = Xbool { unXbool :: String }+$(genKnownTypeSymbol [t|Xbool|] [e|"bool"|])+$(genSocketed [t|Xbool|] [e|unXbool|] [e|Xbool|])+$(genToParams [t|Xbool|])++ifThenElse :: Xbool -> IxShader ctx i i () -> IxShader ctx i i () -> IxShader ctx i i ()+ifThenElse x a b = do+ nxt_ $ "if (" ++ unSocket x ++ ")"+ sub_ "{" "}" a+ sub_ "else {" "}" b++when :: Xbool -> IxShader ctx i i () -> IxShader ctx i i ()+when x a = do+ nxt_ $ "if (" ++ unSocket x ++ ")"+ sub_ "{" "}" a++unless :: Xbool -> IxShader ctx i i () -> IxShader ctx i i ()+unless x a = do+ nxt_ $ "if (! " ++ unSocket x ++ ")"+ sub_ "{" "}" a