diff --git a/CHANGELOG.md b/CHANGELOG.md index ff4728e..1492254 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,7 +12,33 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ### Changed +## [0.2.0] - 2025-12-25 + +### Added + +- 100% documentation coverage +- `haskellPackages.hlint` in `flake.nix` dev shell +- `README.md` + +### Changed + +- split into the following modules + - `GLSL` + - `GLSL.Compile` + - `GLSL.Internal` + - `GLSL.Internal.Compile` +- only the former 2 have type-safe gurantees for generated code +- most projects should only import the former 2 + - see sample in `Main.hs` + +### Fixed + +- issue where user was expected to correctly type variable declarations + - user must now only use the correct constructor + - old: `someVar = var (id "some_var") T'float :: Exp T'float` + - new: `someVar = var'float $ id "some_var"` + ## [0.1.0] - 2025-12-21 - initialized project -- added CHANGELOG.md +- added `CHANGELOG.md` diff --git a/README.md b/README.md new file mode 100644 index 0000000..bd72ce0 --- /dev/null +++ b/README.md @@ -0,0 +1,30 @@ +## installation + +#### with Nix: + +```bash +nix run git+https://git.mtgmonkey.net/Andromeda/hs-glsl +``` + +#### without Nix: + +```bash +git clone https://git.mtgmonkey.net/Andromeda/hs-glsl +cd hs-glsl +cabal build +``` + +## usage + +see `src/Main.hs` for an example + +## development + +#### with Nix + +```bash +git clone https://git.mtgmonkey.net/Andromeda/hs-glsl +cd hs-glsl +nix develop +``` + diff --git a/flake.nix b/flake.nix index 5d9c7a2..9abb136 100644 --- a/flake.nix +++ b/flake.nix @@ -18,6 +18,7 @@ default = pkgs.mkShell { packages = [ pkgs.cabal-install + pkgs.haskellPackages.hlint ]; inputsFrom = [ self.packages.${system}.default diff --git a/hs-glsl.cabal b/hs-glsl.cabal index ecfccc8..134f3ae 100644 --- a/hs-glsl.cabal +++ b/hs-glsl.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hs-glsl -version: 0.1.0 +version: 0.2.0 homepage: https://git.mtgmonkey.net/Andromeda/hs-glsl license: BSD-3-Clause license-file: LICENSE @@ -11,15 +11,23 @@ build-type: Simple common warnings ghc-options: -Wall + -Werror library import: warnings build-depends: base >=4.20 hs-source-dirs: src - exposed-modules: Lib + exposed-modules: GLSL + , GLSL.Compile + , GLSL.Internal + , GLSL.Internal.Compile default-language: Haskell2010 executable hs-glsl import: warnings main-is: Main.hs build-depends: base >=4.20 hs-source-dirs: src + other-modules: GLSL + , GLSL.Compile + , GLSL.Internal + , GLSL.Internal.Compile default-language: Haskell2010 diff --git a/src/GLSL.hs b/src/GLSL.hs new file mode 100644 index 0000000..c71815f --- /dev/null +++ b/src/GLSL.hs @@ -0,0 +1,261 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{- | + - Module : GLSL + - Description : DSEL of GLSL + - Copyright : 2025 Andromeda + - License : BSD 3-Clause + - Maintainer : @Andromeda:tchncs.de + - Stability : Experimental + -} +module GLSL + ( float + , bool + , vec2 + , vec3 + , vec4 + , normalize + , mul + , add + , dec_var + , var'float + , var'bool + , var'vec2 + , var'vec3 + , var'vec4 + , var'mat4 + , GLSL.id + , mkShaders + + , Type (..) + , T'float + , T'bool + , T'vec2 + , T'vec3 + , T'vec4 + , T'mat4 + , Exp + ) +where + +import GLSL.Internal +import Prelude hiding (id) + +-- | statically typed expression; typed wrapper of a dynamic expression +-- only exposed through smart constructors +newtype Exp a = E DExp deriving Show +type E'float = Exp T'float +type E'bool = Exp T'bool +type E'vec2 = Exp T'vec2 +type E'vec3 = Exp T'vec3 +type E'vec4 = Exp T'vec4 +type E'mat4 = Exp T'mat4 + +class Vec2 a where + -- | converts some input to a vec2 + -- some inpu' should be a single value or a tuple of values + vec2 :: a -> E'vec2 +instance Vec2 (E'float, E'float) where + vec2 + ( E a + , E b) + = E $ Lit'vec2 $ E'vec2_2 a b + +class Vec3 a where + -- | converts some input to a vec3 + -- some input should be a single value or a tuple of values + vec3 :: a -> E'vec3 +instance Vec3 (E'float, E'float, E'float) where + vec3 + ( E a + , E b + , E c) + = E $ Lit'vec3 $ E'vec3_3 a b c +instance Vec3 (E'vec2, E'float) where + vec3 + ( E a + , E b) + = E $ Lit'vec3 $ E'vec3_2 a b +instance Vec3 (E'float, E'vec2) where + vec3 + ( E a + , E b) + = E $ Lit'vec3 $ E'vec3_2 a b + +class Vec4 a where + -- | converts some input to a vec4 + -- some input should be a single value or a tuple of values + vec4 :: a -> E'vec4 +instance Vec4 (E'float, E'float, E'float, E'float) where + vec4 + ( E a + , E b + , E c + , E d) + = E $ Lit'vec4 $ E'vec4_4 a b c d +instance Vec4 (E'vec3, E'float) where + vec4 + ( E a + , E b) + = E $ Lit'vec4 $ E'vec4_2 a b +instance Vec4 (E'float, E'vec3) where + vec4 + ( E a + , E b) + = E $ Lit'vec4 $ E'vec4_2 a b +instance Vec4 (E'vec2, E'float, E'float) where + vec4 + ( E a + , E b + , E c) + = E $ Lit'vec4 $ E'vec4_3 a b c +instance Vec4 (E'float, E'vec2, E'float) where + vec4 + ( E a + , E b + , E c) + = E $ Lit'vec4 $ E'vec4_3 a b c +instance Vec4 (E'float, E'float, E'vec2) where + vec4 + ( E a + , E b + , E c) + = E $ Lit'vec4 $ E'vec4_3 a b c +instance Vec4 (E'vec2, E'vec2) where + vec4 + ( E a + , E b) + = E $ Lit'vec4 $ E'vec4_2 a b + +class Normalize a b | a -> b where + -- | wraps some expression in the normalize glsl builtin + -- a is the same type as b + normalize :: a -> b +instance Normalize E'vec2 E'vec2 where + normalize (E v) = E $ E'normalize v +instance Normalize E'vec3 E'vec3 where + normalize (E v) = E $ E'normalize v +instance Normalize E'vec4 E'vec4 where + normalize (E v) = E $ E'normalize v + +class Add a b c | a b -> c where + -- | puts a + between two expressions + add :: a -> b -> c +instance Add E'float E'float E'float where + add (E a) (E b) = E $ E'add a b +instance Add E'float E'vec2 E'vec2 where + add (E a) (E b) = E $ E'add a b +instance Add E'float E'vec3 E'vec3 where + add (E a) (E b) = E $ E'add a b +instance Add E'float E'vec4 E'vec4 where + add (E a) (E b) = E $ E'add a b + +class Mul a b c | a b -> c where + -- | puts a * between two expressions + mul :: a -> b -> c +instance Mul E'float E'float E'float where + mul (E a) (E b) = E $ E'mul a b +instance Mul E'float E'vec2 E'vec2 where + mul (E a) (E b) = E $ E'mul a b +instance Mul E'float E'vec3 E'vec3 where + mul (E a) (E b) = E $ E'mul a b +instance Mul E'float E'vec4 E'vec4 where + mul (E a) (E b) = E $ E'mul a b +instance Mul E'mat4 E'vec4 E'vec4 where + mul (E a) (E b) = E $ E'mul a b + +-- | creates a boolean literal expression +bool :: Bool -> E'bool +bool x = E $ Lit'bool x + +-- | creates a typed float literal expression +float :: Float -> E'float +float x = E $ Lit'float x + +-- | creates a variable with type float +var'float :: Id -> E'float +var'float name = var name T'float + +-- | creates a variable with type bool +var'bool :: Id -> E'bool +var'bool name = var name T'bool + +-- | creates a variable with type vec2 +var'vec2 :: Id -> E'vec2 +var'vec2 name = var name T'vec2 + +-- | creates a variable with type vec3 +var'vec3 :: Id -> E'vec3 +var'vec3 name = var name T'vec3 + +-- | creates a variable with type vec4 +var'vec4 :: Id -> E'vec4 +var'vec4 name = var name T'vec4 + +-- | creates a variable with type mat4 +var'mat4 :: Id -> E'mat4 +var'mat4 name = var name T'mat4 + +-- | creates a literal variable object to pass to mkShaders +dec_var :: Id -> Type -> Var +dec_var name t = Var name t + +-- | creates an Id from a String +id :: String -> Id +id (c:cs) = + let + nondigits = ['a'..'z'] ++ ['A'..'Z'] ++ ['_'] + digits = ['0'..'9'] + in + if elem c nondigits && [] == filter (\e -> notElem e (digits ++ nondigits)) cs + then + Id (c:cs) + else + error $ "invalid identifier <" ++ (c:cs) ++ ">" +id "" = error "invalid blank identifier <>" + +-- | creates shaders that fulfill the desired behaviour +mkShaders + :: [Var] -- ^ uniforms + -> [(Int, Var)] -- ^ vertex shader inputs + -> E'vec4 -- ^ vertex shader gl_Position expression + -> [(Var, Exp t)] -- ^ passthrough variables from vertex to fragment shader + -> Id -- ^ fragment shader output variable name + -> E'vec4 -- ^ fragment shader expression + -> (Shader, Shader) -- ^ (vert, frag) +mkShaders + uniforms + vertex_inputs + (E gl_Position_expr) + passthroughs + out_id + (E out_expr) + = + let + passthroughVars = map fst passthroughs + in + ( VertexShader + Version'330_core + vertex_inputs + passthroughVars + uniforms + (E'let (Var (Id "gl_Position") T'vec4) gl_Position_expr + : map (\(ft, sd) -> E'let ft (unE sd)) passthroughs) + , FragmentShader + Version'330_core + passthroughVars + [Var out_id T'vec4] + uniforms + [E'let (Var out_id T'vec4) out_expr] + ) + +-------------------------------------------------------------------------------- +-- internal constructors TODO remove +-------------------------------------------------------------------------------- + +unE :: Exp t -> DExp +unE (E a) = a + +var :: Id -> Type -> Exp t +var name t = E $ E'var $ Var name t diff --git a/src/GLSL/Compile.hs b/src/GLSL/Compile.hs new file mode 100644 index 0000000..c504988 --- /dev/null +++ b/src/GLSL/Compile.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{- | + - Module : GLSL.Compile + - Description : lets prints + - Copyright : 2025 Andromeda + - License : BSD 3-Clause + - Maintainer : @Andromeda:tchncs.de + - Stability : Experimental + - TODO add internal module + -} +module GLSL.Compile + ( uncheckedCompileShader ) +where + +import GLSL.Internal +import GLSL.Internal.Compile + +-- | TODO indents, pretty/ugly printing +uncheckedCompileShader :: Shader -> String +uncheckedCompileShader + (FragmentShader + version + inputs + outputs + uniforms + body + ) + = + (showVersion version) ++ + "\n" ++ + (unlines $ + (map (\a -> a ++ ";") ( + map showUniform uniforms + ++ map showIn inputs + ++ map showOut outputs + )) + ++ [ "void main() {" ] + ++ map (\a -> showDExp a ++ ";") body + ++ [ "}" ] + ) +uncheckedCompileShader + (VertexShader + version + inputs + outputs + uniforms + body + ) + = + showVersion version ++ "\n" ++ + (unlines $ + map (\a -> a ++ ";") ( + map showUniform uniforms + ++ map showLayoutIn inputs + ++ map showOut outputs + ) + ++ [ "void main() {" ] + ++ map (\a -> showDExp a ++ ";") body + ++ [ "}" ] + ) diff --git a/src/GLSL/Internal.hs b/src/GLSL/Internal.hs new file mode 100644 index 0000000..e2679b3 --- /dev/null +++ b/src/GLSL/Internal.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{- | + - Module : GLSL.Internal + - Description : internal (dynamic) representation of GLSL + - Copyright : 2025 Andromeda + - License : BSD 3-Clause + - Maintainer : @Andromeda:tchncs.de + - Stability : Experimental + -} +module GLSL.Internal where + +-- | literal shaders +data Shader + = VertexShader + Version -- ^ version + [(Int, Var)] -- ^ inputs in form (layoutIndex, input) + [Var] -- ^ outputs + [Var] -- ^ uniforms + [DExp] -- ^ body + | FragmentShader + Version -- ^ version + [Var] -- ^ inputs + [Var] -- ^ outputs + [Var] -- ^ uniforms + [DExp] -- ^ body + deriving Show + +-- | version adt +data Version + = Version'330_core + deriving Show + +-- | dynamically typed expressions +data DExp + = Lit'float Float + | Lit'bool Bool + | Lit'vec2 DExp + | Lit'vec3 DExp + | Lit'vec4 DExp + | E'var Var + | E'let Var DExp + | E'if DExp DExp DExp + | E'add DExp DExp + | E'mul DExp DExp + | E'normalize DExp + + -- TODO move these somewhere else? maybe + | E'vec2_2 DExp DExp + | E'vec3_2 DExp DExp + | E'vec3_3 DExp DExp DExp + | E'vec4_2 DExp DExp + | E'vec4_3 DExp DExp DExp + | E'vec4_4 DExp DExp DExp DExp + deriving Show + +-- | stores variable declaration +data Var + = Var Id Type + deriving Show + +-- | GLSL types +data Type + = T'bool + | T'float + | T'vec2 + | T'vec3 + | T'vec4 + | T'mat4 + deriving Show + +-- | float +data T'float + +-- | bool +data T'bool + +-- | vec2 +data T'vec2 + +-- | vec3 +data T'vec3 + +-- | vec4 +data T'vec4 + +-- | mat4 +data T'mat4 + +-- | identifier for variables +newtype Id = Id String deriving Show diff --git a/src/GLSL/Internal/Compile.hs b/src/GLSL/Internal/Compile.hs new file mode 100644 index 0000000..be00bdb --- /dev/null +++ b/src/GLSL/Internal/Compile.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FunctionalDependencies #-} +{- | + - Module : GLSL.Internal.Compile + - Description : prints + - Copyright : 2025 Andromeda + - License : BSD 3-Clause + - Maintainer : @Andromeda:tchncs.de + - Stability : Experimental + -} +module GLSL.Internal.Compile where + +import GLSL.Internal + +-- | prints version as version header +showVersion :: Version -> String +showVersion Version'330_core = "#version 330 core" + +-- | prints variable with uniform qualifier +showUniform :: Var -> String +showUniform var = "uniform " ++ showVar var + +-- | prints variable with in qualifier +showIn :: Var -> String +showIn var = "in " ++ showVar var + +-- | prints variable with layout (location = <>) in qualifier +showLayoutIn :: (Int, Var) -> String +showLayoutIn (i, var) = "layout (location = " ++ show i ++ ") in " ++ showVar var + +-- | prints variable with out qualifier +showOut :: Var -> String +showOut var = "out " ++ showVar var + +-- | prints variable declaration +showVar :: Var -> String +showVar (Var name typ) = showType typ ++ " " ++ showId name + +-- | prints a dynamic expression +showDExp :: DExp -> String +showDExp (Lit'float f) = show f +showDExp (E'var (Var name _)) = showId name +showDExp (E'let (Var name _) exp0) = showId name ++ " = " ++ showDExp exp0 +showDExp (E'if cond exp0 exp1) = "if " ++ showDExp cond ++ "\nthen\n" ++ showDExp exp0 ++ "\nelse\n" ++ showDExp exp1 +showDExp (E'add exp0 exp1) = showDExp exp0 ++ " + " ++ showDExp exp1 +showDExp (E'mul exp0 exp1) = showDExp exp0 ++ " * " ++ showDExp exp1 +showDExp (E'normalize exp0) = "normalize(" ++ showDExp exp0 ++ ")" +showDExp (Lit'bool cond) = if cond then "true" else "false" +showDExp (Lit'vec2 exp0) = showDExp exp0 +showDExp (Lit'vec3 exp0) = showDExp exp0 +showDExp (Lit'vec4 exp0) = showDExp exp0 +showDExp (E'vec2_2 f0 f1) = "vec2(" ++ showDExp f0 ++ ", " ++ showDExp f1 ++ ")" +showDExp (E'vec3_2 f0 f1) = "vec3(" ++ showDExp f0 ++ ", " ++ showDExp f1 ++ ")" +showDExp (E'vec4_2 f0 f1) = "vec4(" ++ showDExp f0 ++ ", " ++ showDExp f1 ++ ")" +showDExp (E'vec3_3 f0 f1 f2) = "vec3(" ++ showDExp f0 ++ ", " ++ showDExp f1 ++ ", " ++ showDExp f2 ++ ")" +showDExp (E'vec4_3 f0 f1 f2) = "vec4(" ++ showDExp f0 ++ ", " ++ showDExp f1 ++ ", " ++ showDExp f2 ++ ")" +showDExp (E'vec4_4 f0 f1 f2 f3) = "vec4(" ++ showDExp f0 ++ ", " ++ showDExp f1 ++ ", " ++ showDExp f2 ++ ", " ++ showDExp f3 ++ ")" + +-- | toString for Type +showType :: Type -> String +showType T'bool = "bool" +showType T'float = "float" +showType T'vec2 = "vec2" +showType T'vec3 = "vec3" +showType T'vec4 = "vec4" +showType T'mat4 = "mat4" + +-- | prints verbatim identifier +showId :: Id -> String +showId (Id s) = s diff --git a/src/Lib.hs b/src/Lib.hs deleted file mode 100644 index 2f52d9b..0000000 --- a/src/Lib.hs +++ /dev/null @@ -1,412 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FunctionalDependencies #-} -{- | - - Module : Lib - - Description : representation of GLSL shader language - - Copyright : 2025 Andromeda - - License : BSD 3-Clause - - Maintainer : @Andromeda:tchncs.de - - Stability : Experimental - - TODO add internal module - -} -module Lib - ( uncheckedCompileShader - , float - , bool - , vec2 - , vec3 - , vec4 - , normalize - , mul - , add - , dec_var - , var'float - , var'bool - , var'vec2 - , var'vec3 - , var'vec4 - , var'mat4 - , Lib.id - , mkShaders - - , Type (..) - , T'float - , T'bool - , T'vec2 - , T'vec3 - , T'vec4 - , T'mat4 - , Exp - ) -where - --------------------------------------------------------------------------------- --- dynamic expressions --------------------------------------------------------------------------------- - --- | literal shaders -data Shader - = VertexShader - Version -- ^ version - [(Int, Var)] -- ^ inputs in form (layoutIndex, input) - [Var] -- ^ outputs - [Var] -- ^ uniforms - [DExp] -- ^ body - | FragmentShader - Version -- ^ version - [Var] -- ^ inputs - [Var] -- ^ outputs - [Var] -- ^ uniforms - [DExp] -- ^ body - deriving Show - --- | version adt -data Version - = Version'330_core - deriving Show - --- | dynamically typed expressions -data DExp - = Lit'float Float - | Lit'bool Bool - | Lit'vec2 DExp - | Lit'vec3 DExp - | Lit'vec4 DExp - | E'var Var - | E'let Var DExp - | E'if DExp DExp DExp - | E'add DExp DExp - | E'mul DExp DExp - | E'normalize DExp - - -- TODO move these somewhere else? maybe - | E'vec2_2 DExp DExp - | E'vec3_2 DExp DExp - | E'vec3_3 DExp DExp DExp - | E'vec4_2 DExp DExp - | E'vec4_3 DExp DExp DExp - | E'vec4_4 DExp DExp DExp DExp - deriving Show - --- | stores variable declaration --- TODO refactor Var to contain type -data Var - = Var Id Type - deriving Show - --- | GLSL types -data Type - = T'bool - | T'float - | T'vec2 - | T'vec3 - | T'vec4 - | T'mat4 - deriving Show -data T'float -data T'bool -data T'vec2 -data T'vec3 -data T'vec4 -data T'mat4 - --- | identifier for variables -newtype Id = Id String deriving Show - --------------------------------------------------------------------------------- --- expressions --------------------------------------------------------------------------------- - --- | basis to define types -data Exp a = E DExp deriving Show -type E'float = Exp T'float -type E'bool = Exp T'bool -type E'vec2 = Exp T'vec2 -type E'vec3 = Exp T'vec3 -type E'vec4 = Exp T'vec4 -type E'mat4 = Exp T'mat4 - --- | turns an Exp back into DExp --- really only for convenience when printing -unE :: Exp a -> DExp -unE (E exp) = exp - --------------------------------------------------------------------------------- --- smart constructors --------------------------------------------------------------------------------- - -class Vec2 a where - vec2 :: a -> E'vec2 -instance Vec2 (E'float, E'float) where - vec2 - ( E a - , E b) - = E $ Lit'vec2 $ E'vec2_2 a b - -class Vec3 a where - vec3 :: a -> E'vec3 -instance Vec3 (E'float, E'float, E'float) where - vec3 - ( E a - , E b - , E c) - = E $ Lit'vec3 $ E'vec3_3 a b c -instance Vec3 (E'vec2, E'float) where - vec3 - ( E a - , E b) - = E $ Lit'vec3 $ E'vec3_2 a b -instance Vec3 (E'float, E'vec2) where - vec3 - ( E a - , E b) - = E $ Lit'vec3 $ E'vec3_2 a b - -class Vec4 a where - vec4 :: a -> E'vec4 -instance Vec4 (E'float, E'float, E'float, E'float) where - vec4 - ( E a - , E b - , E c - , E d) - = E $ Lit'vec4 $ E'vec4_4 a b c d -instance Vec4 (E'vec3, E'float) where - vec4 - ( E a - , E b) - = E $ Lit'vec4 $ E'vec4_2 a b -instance Vec4 (E'float, E'vec3) where - vec4 - ( E a - , E b) - = E $ Lit'vec4 $ E'vec4_2 a b -instance Vec4 (E'vec2, E'float, E'float) where - vec4 - ( E a - , E b - , E c) - = E $ Lit'vec4 $ E'vec4_3 a b c -instance Vec4 (E'float, E'vec2, E'float) where - vec4 - ( E a - , E b - , E c) - = E $ Lit'vec4 $ E'vec4_3 a b c -instance Vec4 (E'float, E'float, E'vec2) where - vec4 - ( E a - , E b - , E c) - = E $ Lit'vec4 $ E'vec4_3 a b c -instance Vec4 (E'vec2, E'vec2) where - vec4 - ( E a - , E b) - = E $ Lit'vec4 $ E'vec4_2 a b - -class Normalize a b | a -> b where - normalize :: a -> b -instance Normalize E'vec2 E'vec2 where - normalize (E v) = E $ E'normalize v -instance Normalize E'vec3 E'vec3 where - normalize (E v) = E $ E'normalize v -instance Normalize E'vec4 E'vec4 where - normalize (E v) = E $ E'normalize v - -class Add a b c | a b -> c where - add :: a -> b -> c -instance Add E'float E'float E'float where - add (E a) (E b) = E $ E'add a b -instance Add E'float E'vec2 E'vec2 where - add (E a) (E b) = E $ E'add a b -instance Add E'float E'vec3 E'vec3 where - add (E a) (E b) = E $ E'add a b -instance Add E'float E'vec4 E'vec4 where - add (E a) (E b) = E $ E'add a b - -class Mul a b c | a b -> c where - mul :: a -> b -> c -instance Mul E'float E'float E'float where - mul (E a) (E b) = E $ E'mul a b -instance Mul E'float E'vec2 E'vec2 where - mul (E a) (E b) = E $ E'mul a b -instance Mul E'float E'vec3 E'vec3 where - mul (E a) (E b) = E $ E'mul a b -instance Mul E'float E'vec4 E'vec4 where - mul (E a) (E b) = E $ E'mul a b -instance Mul E'mat4 E'vec4 E'vec4 where - mul (E a) (E b) = E $ E'mul a b - -bool :: Bool -> E'bool -bool x = E (Lit'bool x) - -float :: Float -> E'float -float x = E (Lit'float x) - -var :: Id -> Type -> Exp t -var id t = E $ E'var $ Var id t - --- | constructors for variables -var'float :: Id -> E'float -var'float id = var id T'float -var'bool :: Id -> E'bool -var'bool id = var id T'bool -var'vec2 :: Id -> E'vec2 -var'vec2 id = var id T'vec2 -var'vec3 :: Id -> E'vec3 -var'vec3 id = var id T'vec3 -var'vec4 :: Id -> E'vec4 -var'vec4 id = var id T'vec4 -var'mat4 :: Id -> E'mat4 -var'mat4 id = var id T'mat4 - --- | variable declaration -dec_var :: Id -> Type -> Var -dec_var id t = Var id t - --- | TODO make this not throw an error? -id :: String -> Id -id (c:cs) = - let - nondigits = ['a'..'z'] ++ ['A'..'Z'] ++ ['_'] - digits = ['0'..'9'] - in - if elem c nondigits && [] == filter (\e -> not $ elem e (digits ++ nondigits)) cs - then - Id (c:cs) - else - error $ "invalid identifier <" ++ (c:cs) ++ ">" - --- | TODO simplify interface -mkShaders - :: [Var] -- ^ uniforms - -> [(Int, Var)] -- ^ vertex shader inputs - -> E'vec4 -- ^ vertex shader gl_Position expression - -> [(Var, Exp t)] -- ^ passthrough variables from vertex to fragment shader - -> Id -- ^ fragment shader output variable name - -> E'vec4 -- ^ fragment shader expression - -> (Shader, Shader) -- ^ (vert, frag) -mkShaders - uniforms - vertex_inputs - gl_Position_expr - passthroughs - out_id - out_expr - = - let - passthroughVars = map fst passthroughs - passthroughExprs = map snd passthroughs - in - ( VertexShader - Version'330_core - vertex_inputs - passthroughVars - uniforms - ([E'let (Var (Id "gl_Position") T'vec4) (unE gl_Position_expr)] ++ - map (\(ft, sd) -> E'let ft (unE sd)) passthroughs) - , FragmentShader - Version'330_core - passthroughVars - [(Var out_id T'vec4)] - uniforms - [E'let (Var out_id T'vec4) (unE out_expr)] - ) - --------------------------------------------------------------------------------- --- printing --------------------------------------------------------------------------------- - --- | TODO indents, pretty/ugly printing -uncheckedCompileShader :: Shader -> String -uncheckedCompileShader - (FragmentShader - version - inputs - outputs - uniforms - body - ) - = - showVersion version ++ "\n" ++ - (unlines $ - map (\a -> a ++ ";") ( - map showUniform uniforms - ++ map showIn inputs - ++ map showOut outputs - ) - ++ [ "void main() {" ] - ++ map (\a -> showDExp a ++ ";") body - ++ [ "}" ] - ) -uncheckedCompileShader - (VertexShader - version - inputs - outputs - uniforms - body - ) - = - showVersion version ++ "\n" ++ - (unlines $ - map (\a -> a ++ ";") ( - map showUniform uniforms - ++ map showLayoutIn inputs - ++ map showOut outputs - ) - ++ [ "void main() {" ] - ++ map (\a -> showDExp a ++ ";") body - ++ [ "}" ] - ) - -showVersion :: Version -> String -showVersion Version'330_core = "#version 330 core" - -showUniform :: Var -> String -showUniform var = "uniform " ++ showVar var - -showIn :: Var -> String -showIn var = "in " ++ showVar var - -showLayoutIn :: (Int, Var) -> String -showLayoutIn (i, var) = "layout (location = " ++ show i ++ ") in " ++ showVar var - -showOut :: Var -> String -showOut var = "out " ++ showVar var - -showVar :: Var -> String -showVar (Var id typ) = showType typ ++ " " ++ showId id - -showDExp :: DExp -> String -showDExp (Lit'float f) = show f -showDExp (E'var (Var id _)) = showId id -showDExp (E'let (Var id _) exp) = showId id ++ " = " ++ showDExp exp -showDExp (E'if cond exp1 exp2) = "if " ++ showDExp cond ++ "\nthen\n" ++ showDExp exp1 ++ "\nelse\n" ++ showDExp exp2 -showDExp (E'add exp1 exp2) = showDExp exp1 ++ " + " ++ showDExp exp2 -showDExp (E'mul exp1 exp2) = showDExp exp1 ++ " * " ++ showDExp exp2 -showDExp (E'normalize exp1) = "normalize(" ++ showDExp exp1 ++ ")" -showDExp (Lit'bool bool) = if bool then "true" else "false" -showDExp (Lit'vec2 exp) = showDExp exp -showDExp (Lit'vec3 exp) = showDExp exp -showDExp (Lit'vec4 exp) = showDExp exp -showDExp (E'vec2_2 f0 f1) = "vec2(" ++ showDExp f0 ++ ", " ++ showDExp f1 ++ ")" -showDExp (E'vec3_2 f0 f1) = "vec3(" ++ showDExp f0 ++ ", " ++ showDExp f1 ++ ")" -showDExp (E'vec4_2 f0 f1) = "vec4(" ++ showDExp f0 ++ ", " ++ showDExp f1 ++ ")" -showDExp (E'vec3_3 f0 f1 f2) = "vec3(" ++ showDExp f0 ++ ", " ++ showDExp f1 ++ ", " ++ showDExp f2 ++ ")" -showDExp (E'vec4_3 f0 f1 f2) = "vec4(" ++ showDExp f0 ++ ", " ++ showDExp f1 ++ ", " ++ showDExp f2 ++ ")" -showDExp (E'vec4_4 f0 f1 f2 f3) = "vec4(" ++ showDExp f0 ++ ", " ++ showDExp f1 ++ ", " ++ showDExp f2 ++ ", " ++ showDExp f3 ++ ")" - -showType :: Type -> String -showType T'bool = "bool" -showType T'float = "float" -showType T'vec2 = "vec2" -showType T'vec3 = "vec3" -showType T'vec4 = "vec4" -showType T'mat4 = "mat4" - -showId :: Id -> String -showId (Id s) = s diff --git a/src/Main.hs b/src/Main.hs index bd14ef5..096e5c3 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,7 +1,8 @@ module Main (main) where import Prelude hiding (id) -import Lib +import GLSL +import GLSL.Compile main :: IO () main = do