From 298a13b60d15e1aa11e0278a556fcd8edaa6b0c4 Mon Sep 17 00:00:00 2001 From: mtgmonkey Date: Mon, 22 Dec 2025 15:58:44 +0100 Subject: [PATCH] init neue --- .gitignore | 2 + LICENSE | 29 +++ flake.lock | 8 +- flake.nix | 21 +- hs-glsl.cabal | 25 +++ src/Language/GLSL.hs | 271 ---------------------- src/Language/GLSL/Examples.hs | 47 ---- src/Lib.hs | 412 ++++++++++++++++++++++++++++++++++ src/Main.hs | 49 ++++ 9 files changed, 539 insertions(+), 325 deletions(-) create mode 100644 .gitignore create mode 100644 LICENSE create mode 100644 hs-glsl.cabal delete mode 100644 src/Language/GLSL.hs delete mode 100644 src/Language/GLSL/Examples.hs create mode 100644 src/Lib.hs create mode 100644 src/Main.hs diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..1f594a8 --- /dev/null +++ b/.gitignore @@ -0,0 +1,2 @@ +result +dist-newstyle diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..8e6264d --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2025, andromeda + + +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 the copyright holder nor the names of its + 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 +HOLDER 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. diff --git a/flake.lock b/flake.lock index 0ab51bd..14af65c 100644 --- a/flake.lock +++ b/flake.lock @@ -2,16 +2,16 @@ "nodes": { "nixpkgs": { "locked": { - "lastModified": 1764242076, - "narHash": "sha256-sKoIWfnijJ0+9e4wRvIgm/HgE27bzwQxcEmo2J/gNpI=", + "lastModified": 1766125104, + "narHash": "sha256-l/YGrEpLromL4viUo5GmFH3K5M1j0Mb9O+LiaeCPWEM=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "2fad6eac6077f03fe109c4d4eb171cf96791faa4", + "rev": "7d853e518814cca2a657b72eeba67ae20ebf7059", "type": "github" }, "original": { "id": "nixpkgs", - "ref": "nixos-unstable", + "ref": "nixpkgs-unstable", "type": "indirect" } }, diff --git a/flake.nix b/flake.nix index 745dfb3..5d9c7a2 100644 --- a/flake.nix +++ b/flake.nix @@ -1,13 +1,28 @@ { inputs = { - nixpkgs.url = "nixpkgs/nixos-unstable"; + nixpkgs.url = "nixpkgs/nixpkgs-unstable"; }; - outputs = {nixpkgs, ...}: let + outputs = { + nixpkgs, + self, + ... + }: let system = "x86_64-linux"; pkgs = nixpkgs.legacyPackages.${system}; in { packages.${system} = { - default = pkgs.callPackage ./package.nix {}; + default = + pkgs.haskellPackages.callCabal2nix "hs-glsl" ./. {}; + }; + devShells.${system} = { + default = pkgs.mkShell { + packages = [ + pkgs.cabal-install + ]; + inputsFrom = [ + self.packages.${system}.default + ]; + }; }; }; } diff --git a/hs-glsl.cabal b/hs-glsl.cabal new file mode 100644 index 0000000..ecfccc8 --- /dev/null +++ b/hs-glsl.cabal @@ -0,0 +1,25 @@ +cabal-version: 3.0 +name: hs-glsl +version: 0.1.0 +homepage: https://git.mtgmonkey.net/Andromeda/hs-glsl +license: BSD-3-Clause +license-file: LICENSE +author: andromeda +maintainer: @Andromeda:tchncs.de +category: Graphics +build-type: Simple +common warnings + ghc-options: + -Wall +library + import: warnings + build-depends: base >=4.20 + hs-source-dirs: src + exposed-modules: Lib + default-language: Haskell2010 +executable hs-glsl + import: warnings + main-is: Main.hs + build-depends: base >=4.20 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/Language/GLSL.hs b/src/Language/GLSL.hs deleted file mode 100644 index adb002a..0000000 --- a/src/Language/GLSL.hs +++ /dev/null @@ -1,271 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.GLSL - ( Program - , Expressions - , Expression(..) - , RequestedGLVersion - , RequestedGLType(..) - , ParameterQualifier(..) - , LayoutQualifier(..) - , Variables - , VariableName - , Variable(..) - , GLSLType(..) - , generateGLSL - , generateCheckedGLSL - ) -where - --- TODO --- --- -[ ] Add support for multiple shaders in sequence --- -[ ] Add check if the previous shader output the next shader's inputs - --- IMPORTS -- - -import Relude - --- CLASSES -- - -class GLSLExpression a where - -- should display the token that the type represents - toGLSLText :: a -> Text - -instance GLSLExpression Program where - toGLSLText expressions = - foldr ((<>)) "}\n" $ map (toGLSLText) expressions - -instance GLSLExpression Expression where - toGLSLText - (VersionDeclaration requestedGLVersion requestedGLType) = - "#version " <> - (toGLSLText requestedGLVersion) <> - " " <> - (toGLSLText requestedGLType) <> - "\n" - toGLSLText - (VariableDeclaration - (Just (Location location)) - parameterQualifier - (Variable variableName glslType)) = - "layout (location = " <> - (toGLSLText location) <> - ") " <> - (toGLSLText parameterQualifier) <> - " " <> - (toGLSLText glslType) <> - " " <> - variableName <> - ";\n" - toGLSLText - (VariableDeclaration - Nothing - parameterQualifier - (Variable variableName glslType)) = - (toGLSLText parameterQualifier) <> - " " <> - (toGLSLText glslType) <> - " " <> - variableName <> - ";\n" - toGLSLText - MainStart = - "void main()\n{\n" - toGLSLText - (VariableAssignment - variable0 - variable1) = - (toGLSLText variable0) <> - " = " <> - (toGLSLText variable1) <> - ";\n" - toGLSLText - (DangerousExpression text) = - text <> - "\n" - -instance GLSLExpression RequestedGLVersion where - toGLSLText i = show i - -instance GLSLExpression RequestedGLType where - toGLSLText Core = "core" - -instance GLSLExpression ParameterQualifier where - toGLSLText In = "in" - toGLSLText Out = "out" - toGLSLText Uniform = "uniform" - -instance GLSLExpression Variable where - toGLSLText GL_POSITION = "gl_Position" - toGLSLText (Variable name _) = name - -instance GLSLExpression GLSLType where - toGLSLText (GLSLVec4 _) = "vec4" - toGLSLText (GLSLVec3 _) = "vec3" - toGLSLText (GLSLVec2 _) = "vec2" - toGLSLText (GLSLMat4 _) = "mat4" - toGLSLText GLSLFloat = "float" - --- TYPES -- - -type Program = Expressions - --- version declaration - -type RequestedGLVersion = Int -data RequestedGLType - = Core - deriving Show - --- variables - -data ParameterQualifier - = In - | Out - | Uniform - deriving (Eq, Show) - -data LayoutQualifier - = Location Int - deriving Show - -type Variables = [Variable] -type VariableName = Text - -data Variable - = Variable - VariableName - GLSLType - | GL_POSITION - deriving (Eq, Show) - -data GLSLType - = GLSLFloat - | GLSLVec4 GLSLType - | GLSLVec3 GLSLType - | GLSLVec2 GLSLType - | GLSLMat4 GLSLType - deriving (Eq, Show) - --- expressions - -type Expressions = [Expression] - -data Expression - = VersionDeclaration - RequestedGLVersion - RequestedGLType - | VariableDeclaration - (Maybe LayoutQualifier) - ParameterQualifier - Variable - | MainStart - | VariableAssignment - Variable - Variable - | DangerousExpression - Text - deriving Show - --- errors - -type Check = CheckSuccess -> CheckResult -type CheckResult = Either CheckFailure CheckSuccess -type CheckSuccess = (Program, [Warn]) -type CheckFailure = (Error, [Warn]) - -data Error - = ErrUnimplementedCheckProgram - | ErrVariableDeclaredMultipleTimes Variables - | ErrVariableOutputUnassigned Variables - deriving Show - -data Warn - = WarnVariableAssignedMultipleTimes Variable Int - | WarnVariableUnassigned Variable - deriving Show - -generateGLSL :: Program -> Text -generateGLSL = toGLSLText - -generateCheckedGLSL :: Program -> Either CheckFailure (Text, [Warn]) -generateCheckedGLSL program = - case checkProgram (program, []) of - Left (e, warnings) -> Left (e, warnings) - Right (program, warnings) -> Right (toGLSLText program, warnings) - -checkProgram :: Check -checkProgram program - = checkVariableDeclaredMultipleTimes program - >>= checkVariableOutputUnassigned - >>= checkVariableAssignedMultipleTimes - >>= checkVariableUnassigned - --- throws error if variable declared multiple times -checkVariableDeclaredMultipleTimes :: Check -checkVariableDeclaredMultipleTimes (program, warnings) - = case [var | (var, ct) <- counts [v | VariableDeclaration _ _ v <- program] - , ct > 1 - ] of - [] -> Right (program, warnings) - a -> Left (ErrVariableDeclaredMultipleTimes a, warnings) - --- throws error if `out` variable unassigned -checkVariableOutputUnassigned :: Check -checkVariableOutputUnassigned (program, warnings) - = case - [v | v <- [var | VariableDeclaration _ Out var <- program] - , not $ elem v [var | VariableAssignment var _ <- program] - ] of - [] -> Right (program, warnings) - a -> Left (ErrVariableOutputUnassigned a, warnings) - --- throws warning if variable assigned multiple times -checkVariableAssignedMultipleTimes :: Check -checkVariableAssignedMultipleTimes (program, warnings) - = case [(var, ct) | (var, ct) <- counts [v | VariableAssignment v _ <- program] - , ct > 1 - ] of - [] -> Right (program, warnings) - a -> Right - (program - , (map - (\(var, ct) -> WarnVariableAssignedMultipleTimes var ct) - a) ++ warnings - ) - --- throws warning if non-input variable unassigned -checkVariableUnassigned :: Check -checkVariableUnassigned (program, warnings) - = case - [WarnVariableUnassigned var | VariableDeclaration _ parameterQualifier var <- program - , parameterQualifier /= In - , not $ elem var [var | VariableAssignment var _ <- program] - ] of - [] -> Right (program, warnings) - a -> Right (program, a ++ warnings) - --- utilities - -counts :: (Eq a) => [a] -> [(a, Int)] -counts arr = counts' arr [] - -counts' :: (Eq a) => [a] -> [(a, Int)] -> [(a, Int)] -counts' [] cts = cts -counts' (x:xs) cts = - counts' - xs - $ if [] == [0 | (a, _) <- cts - , a == x - ] - then - (x, 1):cts - else - [(a, ct + 1) | (a, ct) <- cts - , a == x - ] ++ - [t | t@(a, _) <- cts - , a /= x - ] diff --git a/src/Language/GLSL/Examples.hs b/src/Language/GLSL/Examples.hs deleted file mode 100644 index 1aeb728..0000000 --- a/src/Language/GLSL/Examples.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module Language.GLSL.Examples (main) where - --- IMPORTS -- - -import Text.Pretty.Simple - -import Relude - -import Language.GLSL - --- MAIN -- - -main :: IO () -main = do - let a = generateCheckedGLSL fragShader - let b = generateCheckedGLSL vertShader - pPrint a - pPrint b - return () - -fragShader :: Program -fragShader = - [ VersionDeclaration 450 Core - , VariableDeclaration Nothing In fragColorOut - , VariableDeclaration Nothing Out fragColor - , MainStart - , VariableAssignment fragColor fragColorOut - ] - -vertShader :: Program -vertShader = - [ VersionDeclaration 450 Core - , VariableDeclaration (Just $ Location 0) In vertexPosition - , VariableDeclaration (Just $ Location 1) In vertexColor - , VariableDeclaration Nothing Out fragColorOut - , MainStart - , VariableAssignment GL_POSITION vertexPosition - , VariableAssignment fragColorOut vertexColor - ] - -fragColor = Variable "fragColor" $ GLSLVec4 GLSLFloat -fragColorOut = Variable "fragColorOut" $ GLSLVec4 GLSLFloat -vertexPosition = Variable "vertexPosition" $ GLSLVec4 GLSLFloat -vertexColor = Variable "vertexColor" $ GLSLVec4 GLSLFloat diff --git a/src/Lib.hs b/src/Lib.hs new file mode 100644 index 0000000..2f52d9b --- /dev/null +++ b/src/Lib.hs @@ -0,0 +1,412 @@ +{-# 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 new file mode 100644 index 0000000..bd14ef5 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,49 @@ +module Main (main) where + +import Prelude hiding (id) +import Lib + +main :: IO () +main = do + let + -- variables + a_vPos = var'vec3 $ id "a_vPos" + v_pos = var'vec3 $ id "v_pos" + u_view = var'mat4 $ id "u_view" + u_projection = var'mat4 $ id "u_projection" + + -- variable declarations + a_vPos' = dec_var (id "a_vPos") T'vec3 + v_pos' = dec_var (id "v_pos") T'vec3 + u_view' = dec_var (id "u_view") T'mat4 + u_projection' = dec_var (id "u_projection") T'mat4 + + -- shaders + (vert, frag) = mkShaders + -- uniforms + [ u_view' + , u_projection'] + -- vertex inputs + [ (0, a_vPos')] + -- gl_Position expression + ( + u_projection `mul` (u_view `mul` vec4 (v_pos, float 1)) + ) + -- passthrough + [ (v_pos', a_vPos) ] + -- output name + (id "o_vColor") + -- output expression + ( + vec4 + ( float 0.5 `add` + float 0.5 `mul` + normalize v_pos :: Exp T'vec3 + , float 1 + ) + ) + + putStrLn $ show vert + putStrLn $ show frag + putStrLn $ uncheckedCompileShader vert + putStrLn $ uncheckedCompileShader frag