add CHANGELOG.md

.gitignore

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

CHANGELOG.md

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

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.

README.md

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

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

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

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

package.nix

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

src/Language/GLSL.hs

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

src/Language/GLSL/Examples.hs

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

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

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