modularize

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`

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
+```
+

flake.nix

@@ -18,6 +18,7 @@
       default = pkgs.mkShell {
         packages = [
           pkgs.cabal-install
+          pkgs.haskellPackages.hlint
         ];
         inputsFrom = [
           self.packages.${system}.default

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

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

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
+      ++ [ "}" ]
+      )

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

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 <typ> <name>
+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

src/Lib.hs

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

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