Andromeda/hs-glsl
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Compare commits

base: Andromeda:038946ca49f1369ca894f345cc55004d15aa1d19
Branches Tags
Andromeda:master
Andromeda:v0.2.0 Andromeda:v0.1.0
..
compare: Andromeda:v0.1.0
Branches Tags
Andromeda:master
Andromeda:v0.2.0 Andromeda:v0.1.0

4 Commits
038946ca49 ... v0.1.0

Author SHA1 Message Date
mtgmonkey
38c7580cc4 add CHANGELOG.md 2025-12-22 22:37:46 +01:00
mtgmonkey
67202e0f41 remove old files 2025-12-22 16:02:02 +01:00
mtgmonkey
298a13b60d init neue 2025-12-22 15:58:44 +01:00
mtgmonkey
732a4efd33 fix pair compiler warnings 2025-12-03 20:16:51 +01:00
12 changed files with 557 additions and 366 deletions
Expand all files Collapse all files

2
.gitignore vendored Normal file
View File

@@ -0,0 +1,2 @@
result
dist-newstyle

18
CHANGELOG.md Normal file
View File

@@ -0,0 +1,18 @@
# Changelog
All notable changes to this project will be documented in this file.
The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/),
and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).
## [Eventual]
### Added
### Changed
## [0.1.0] - 2025-12-21
- initialized project
- added CHANGELOG.md

29
LICENSE Normal file
View File

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

1
README.md
View File

@@ -1 +0,0 @@
generate type-safe GLSL with this Haskell grammar. Under heavy development.

8
flake.lock generated
View File

@@ -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"
}
},

21
flake.nix
View File

@@ -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
];
};
};
};
}

25
hs-glsl.cabal Normal file
View File

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

38
package.nix
View File

@@ -1,38 +0,0 @@
{
haskellPackages,
lib,
stdenv,
...
}: let
ghcExeOptions = "-O -Wall -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -main-is Language.GLSL.Examples.main";
ghcPackages = p: [
p.relude
p.pretty-simple
];
in
stdenv.mkDerivation {
pname = "hs-glsl";
version = "0.1.0";
src = ./src;
nativeBuildInputs = [
(haskellPackages.ghcWithPackages ghcPackages)
];
buildInputs = [
];
configurePhase = ''
'';
buildPhase = ''
ghc ${ghcExeOptions} ./Language/GLSL/Examples.hs -o ./Main
'';
installPhase = ''
mkdir -p $out/bin
cp ./Main $out/bin/hs-glsl
'';
meta = {
homepage = "https://mtgmonkey.net";
license = lib.licenses.wtfpl;
mainProgram = "hs-glsl";
platforms = ["x86_64-linux"];
};
}

273
src/Language/GLSL.hs
View File

@@ -1,273 +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])
type LineNumber = Int
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, ct) <- cts
, a /= x
]

47
src/Language/GLSL/Examples.hs
View File

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

412
src/Lib.hs Normal file
View File

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

49
src/Main.hs Normal file
View File

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