render: shader: Rename <shader-program> to <shader>.

* sly/render.scm
* sly/render/model.scm (null-model): Use 'null-shader'.
* sly/render/shader.scm (<shader-stage>): Rename to <shader>.
  (<shader-program>): Rename to <shader>.
  (vertex-shader?, fragment-shader?): Rename to...
  (vertex-shader-stage?, fragment-shader-stage?): ...these.
  (shader-stage-guardian): New variable.
  (%shader-compiled?, shader-compiled?): Rename to...
  (%shader-stage-compiled?, shader-stage-compiled?): ...these.
  (display-compilation-error): Change 'shader' to 'stage'.
  (compile-shader, set-shader-source, make-shader, make-vertex-shader)
  (make-fragment-shader, load-shader, load-vertex-shader,
  load-fragment-shader): Rename to...
  (compile-shader-stage, set-shader-stage-source, make-shader-stage)
  (make-vertex-shader-stage, make-fragment-shader-stage)
  (load-shader-stage, load-vertex-shader-stage)
  (load-fragment-shader-stage): ...these.
  (shader-program-uniform-location, shader-program-linked?)
  (make-shader-program, load-shader-program, null-shader-program)
  (apply-shader-program):  Rename to...
  (shader-uniform-location, shader-linked?, make-shader, load-shader)
  (null-shader, apply-shader): ...these.
  (with-shader): Delete.
  (uniform-set!): Change 'shader-program' argument to 'shader'.
  (%default-shader): Use 'load-shader'.

3 files changed, 124 insertions, 146 deletions

diff --git a/sly/render.scm b/sly/render.scm
index 47aa862..b6dd3fb 100644
--- a/sly/render.scm
+++ b/sly/render.scm
@@ -206,7 +206,7 @@
               (graphics-uniform-set! gfx
                                      (uniform-name uniform)
                                      (uniform-default uniform)))
-            (shader-program-uniforms shader)))
+            (shader-uniforms shader)))
 
 (define (make-context-switcher getter setter switch)
   (lambda* (gfx x #:optional force)
@@ -234,7 +234,7 @@
 (define set-graphics-shader!
   (make-context-switcher graphics-shader
                          switch-shader
-                         apply-shader-program))
+                         apply-shader))
 
 (define set-graphics-mesh!
   (make-context-switcher graphics-mesh
diff --git a/sly/render/model.scm b/sly/render/model.scm
index d18ace5..0eb07c0 100644
--- a/sly/render/model.scm
+++ b/sly/render/model.scm
@@ -109,7 +109,7 @@ changing the fields specified in KWARGS."
                     fields field-indices))))))
 
 (define null-model
-  (make-model #:shader null-shader-program))
+  (make-model #:shader null-shader))
 
 (define (model-null? model)
   "Return #t if MODEL has no mesh and no children."
diff --git a/sly/render/shader.scm b/sly/render/shader.scm
index fe2eddd..556d626 100644
--- a/sly/render/shader.scm
+++ b/sly/render/shader.scm
@@ -32,30 +32,17 @@
   #:use-module (sly config)
   #:use-module (sly wrappers gl)
   #:export (make-shader
-            make-vertex-shader
-            make-fragment-shader
-            load-shader
-            load-vertex-shader
-            load-fragment-shader
             shader?
-            vertex-shader?
-            fragment-shader?
-            shader-compiled?
-            shader-type
-            shader-id
-            make-shader-program
-            shader-program?
-            load-shader-program
+            load-shader
+            load-default-shader
             vertex-position-location
             vertex-texture-location
-            shader-program-uniform-location
-            shader-program-id
-            shader-program-uniforms
-            shader-program-linked?
-            null-shader-program
-            apply-shader-program
-            with-shader-program
-            load-default-shader
+            shader-uniform-location
+            shader-id
+            shader-uniforms
+            shader-linked?
+            null-shader
+            apply-shader
             %uniform-setters
             register-uniform-setter!
             uniform?
@@ -86,53 +73,51 @@
 ;;; Shaders
 ;;;
 
-(define-record-type <shader>
-  (%make-shader type id)
-  shader?
-  (type shader-type)
-  (id shader-id))
-
-(define (vertex-shader? shader)
-  "Return #t if SHADER is a vertex shader, #f otherwise."
-  (eq? (shader-type shader) 'vertex))
+(define-record-type <shader-stage>
+  (%make-shader-stage type id)
+  shader-stage?
+  (type shader-stage-type)
+  (id shader-stage-id))
 
-(define (fragment-shader? shader)
-  "Return #t if SHADER is a fragment shader, #f otherwise."
-  (eq? (shader-type shader) 'fragment))
+(define (vertex-shader-stage? stage)
+  "Return #t if STAGE is a vertex shader, #f otherwise."
+  (eq? (shader-stage-type stage) 'vertex))
 
-(define-guardian shader-guardian
-  (lambda (shader)
-    (false-if-exception
-     (glDeleteShader (shader-id shader)))))
+(define (fragment-shader-stage? stage)
+  "Return #t if STAGE is a fragment shader, #f otherwise."
+  (eq? (shader-stage-type stage) 'fragment))
 
 ;; Reap GL shaders when their wrapper objects are GC'd.
-(define-guardian shader-guardian
-  (lambda (shader)
-    (false-if-exception (glDeleteShader (shader-id shader)))))
+(define-guardian shader-stage-guardian
+  (lambda (stage)
+    (false-if-exception
+     (glDeleteShader (shader-stage-id stage)))))
 
-(define-status %shader-compiled? glGetShaderiv compile-status)
+(define-status %shader-stage-compiled? glGetShaderiv compile-status)
 
-(define (shader-compiled? shader)
-  (%shader-compiled? (shader-id shader)))
+(define (shader-stage-compiled? stage)
+  "Return #t if STAGE has been compiled already."
+  (%shader-stage-compiled? (shader-stage-id stage)))
 
 (define-logger %display-compilation-error glGetShaderiv glGetShaderInfoLog)
 
-(define (display-compilation-error shader)
-  (%display-compilation-error (shader-id shader)))
+(define (display-compilation-error stage)
+  (%display-compilation-error (shader-stage-id stage)))
 
-(define (compile-shader shader)
-  "Attempt to compiler SHADER.  Compilation errors are written to
+(define (compile-shader-stage stage)
+  "Attempt to compile STAGE.  Compilation errors are written to
 stdout."
-  (glCompileShader (shader-id shader))
-  (unless (shader-compiled? shader)
+  (glCompileShader (shader-stage-id stage))
+  (unless (shader-stage-compiled? stage)
     (display "Failed to compile shader:\n")
-    (display-compilation-error shader)))
+    (display-compilation-error stage)))
 
-(define (set-shader-source shader source)
-  "Use the GLSL source code in the string SOURCE for SHADER."
+(define (set-shader-stage-source stage source)
+  "Use the GLSL source code in the string SOURCE for the shader
+STAGE."
   (let ((length (u32vector (string-length source)))
         (str (u64vector (pointer-address (string->pointer source)))))
-    (glShaderSource (shader-id shader) 1 (bytevector->pointer str)
+    (glShaderSource (shader-stage-id stage) 1 (bytevector->pointer str)
                     (bytevector->pointer length))))
 
 (define (gl-shader-type type)
@@ -144,42 +129,44 @@ stdout."
         (else
          (error "Invalid shader type: " type))))
 
-(define (make-shader type source)
-  "Create a new GLSL shader of the given TYPE (vertex or fragment) and
-compile the GLSL program contained in the string SOURCE."
+(define (make-shader-stage type source)
+  "Create a new GLSL shader stage of the given TYPE (either 'vertex'
+or 'fragment') and compile the GLSL program contained in the string
+SOURCE."
   (let* ((id (glCreateShader (gl-shader-type type)))
-         (shader (%make-shader type id)))
-    (shader-guardian shader)
-    (set-shader-source shader source)
-    (compile-shader shader)
-    shader))
-
-(define (make-vertex-shader source)
-  "Create a new GLSL vertex shader and compile the GLSL program
-contained in the string SOURCE."
-  (make-shader 'vertex source))
-
-(define (make-fragment-shader source)
-  "Create a new GLSL fragment shader and compile the GLSL program
+         (stage (%make-shader-stage type id)))
+    (shader-stage-guardian stage)
+    (set-shader-stage-source stage source)
+    (compile-shader-stage stage)
+    stage))
+
+(define (make-vertex-shader-stage source)
+  "Create a new GLSL vertex shader stage and compile the GLSL program
 contained in the string SOURCE."
-  (make-shader 'fragment source))
-
-(define (load-shader type filename)
-  "Create a new GLSL shader of the given TYPE (vertex or fragment) and
-compile the GLSL program stored in the file FILENAME."
-  (if (file-exists? filename)
-      (make-shader type (call-with-input-file filename read-string))
-      (error "File not found!" filename)))
-
-(define (load-vertex-shader filename)
-  "Create a new GLSL vertex shader and compile the GLSL program stored
-in the file FILENAME."
-  (load-shader 'vertex filename))
-
-(define (load-fragment-shader filename)
-  "Create a new GLSL vertex shader and compile the GLSL program stored
-in the file FILENAME."
-  (load-shader 'fragment filename))
+  (make-shader-stage 'vertex source))
+
+(define (make-fragment-shader-stage source)
+  "Create a new GLSL fragment shader stage and compile the GLSL
+program contained in the string SOURCE."
+  (make-shader-stage 'fragment source))
+
+(define (load-shader-stage type file-name)
+  "Create a new GLSL shader stage of the given TYPE (either 'vertex'
+or 'fragment') and compile the GLSL program stored in the file
+FILE-NAME."
+  (if (file-exists? file-name)
+      (make-shader-stage type (call-with-input-file file-name read-string))
+      (error "File not found!" file-name)))
+
+(define (load-vertex-shader file-name)
+  "Create a new GLSL vertex shader stage and compile the GLSL program
+stored in the file FILE-NAME."
+  (load-shader-stage 'vertex file-name))
+
+(define (load-fragment-shader file-name)
+  "Create a new GLSL vertex shader stage and compile the GLSL program
+stored in the file FILE-NAME."
+  (load-shader-stage 'fragment file-name))
 
 ;;;
 ;;; Shader Programs
@@ -199,49 +186,49 @@ in the file FILENAME."
   (name attribute-name)
   (location attribute-location))
 
-(define-record-type <shader-program>
-  (%make-shader-program id uniforms)
-  shader-program?
-  (id shader-program-id)
-  (uniforms shader-program-uniforms))
+(define-record-type <shader>
+  (%make-shader id uniforms)
+  shader?
+  (id shader-id)
+  (uniforms shader-uniforms))
 
 ;; Hard-coded vertex attribute locations.  These are fixed so that all
 ;; Sly shaders abide by the same interface.
 (define vertex-position-location 0)
 (define vertex-texture-location 1)
 
-(define (shader-program-uniform-location shader-program name)
+(define (shader-uniform-location shader name)
   (let ((uniform (find (lambda (uniform)
                          (eq? (uniform-name uniform) name))
-                       (shader-program-uniforms shader-program))))
+                       (shader-uniforms shader))))
     (if uniform
         (uniform-location uniform)
         (error "Uniform not found: " name))))
 
-(define-guardian shader-program-guardian
-  (lambda (shader-program)
+(define-guardian shader-guardian
+  (lambda (shader)
     (false-if-exception
-     (glDeleteProgram (shader-program-id shader-program)))))
+     (glDeleteProgram (shader-id shader)))))
 
-(define-status shader-program-linked? glGetProgramiv link-status)
+(define-status shader-linked? glGetProgramiv link-status)
 (define-logger display-linking-error glGetProgramiv glGetProgramInfoLog)
 
-(define (make-shader-program vertex-shader fragment-shader uniforms)
+(define (make-shader vertex-stage fragment-stage uniforms)
   "Create a new shader program that has been linked with the given
-VERTEX-SHADER and FRAGMENT-SHADER."
-  (unless (and (vertex-shader? vertex-shader)
-               (fragment-shader? fragment-shader))
-    (error "Expected a vertex shader and fragment shader"
-           vertex-shader fragment-shader))
+VERTEX-STAGE and FRAGMENT-STAGE."
+  (unless (and (vertex-shader-stage? vertex-stage)
+               (fragment-shader-stage? fragment-stage))
+    (error "Expected vertex and fragment shader stages"
+           vertex-stage fragment-stage))
   (let ((id (glCreateProgram))
-        (shaders (list vertex-shader fragment-shader)))
+        (stages (list vertex-stage fragment-stage)))
     (define build-uniform
       (match-lambda
-       ((name gl-name default)
-        (let ((location (glGetUniformLocation id gl-name)))
-          (if (= location -1)
-              (error "Uniform not found: " gl-name)
-              (make-uniform name gl-name location default))))))
+        ((name gl-name default)
+         (let ((location (glGetUniformLocation id gl-name)))
+           (if (= location -1)
+               (error "Uniform not found: " gl-name)
+               (make-uniform name gl-name location default))))))
 
     (define (string->attribute attribute-name)
       (let ((location (glGetAttribLocation id attribute-name)))
@@ -251,49 +238,40 @@ VERTEX-SHADER and FRAGMENT-SHADER."
 
     (catch #t
       (lambda ()
-        (for-each (lambda (shader)
-                    (glAttachShader id (shader-id shader)))
-                  shaders)
+        (for-each (lambda (stage)
+                    (glAttachShader id (shader-stage-id stage)))
+                  stages)
         ;; Bind attribute locations
         (glBindAttribLocation id vertex-position-location "position")
         (glBindAttribLocation id vertex-texture-location "tex")
         (glLinkProgram id)
-        (unless (shader-program-linked? id)
+        (unless (shader-linked? id)
           (display "Failed to link shader program:\n")
           (display-linking-error id))
         ;; Once the program has been linked, the shaders can be detached.
-        (for-each (lambda (shader)
-                    (glDetachShader id (shader-id shader)))
-                  shaders)
+        (for-each (lambda (stage)
+                    (glDetachShader id (shader-stage-id stage)))
+                  stages)
         (let* ((uniforms (map build-uniform uniforms))
-               (shader-program (%make-shader-program id uniforms)))
-          (shader-program-guardian shader-program)
-          shader-program))
+               (shader (%make-shader id uniforms)))
+          (shader-guardian shader)
+          shader))
       throw
       (lambda _
         ;; Make sure to delete program in case linking fails.
         (glDeleteProgram id)))))
 
-(define* (load-shader-program #:key vertex-source fragment-source
-                              uniforms)
-  (make-shader-program (load-vertex-shader vertex-source)
-                       (load-fragment-shader fragment-source)
-                       uniforms))
-
-(define null-shader-program
-  (%make-shader-program 0 '()))
+(define* (load-shader #:key vertex-source fragment-source
+                      uniforms)
+  (make-shader (load-vertex-shader vertex-source)
+               (load-fragment-shader fragment-source)
+               uniforms))
 
-(define (apply-shader-program shader-program)
-  (glUseProgram (shader-program-id shader-program)))
+(define null-shader
+  (%make-shader 0 '()))
 
-(define-syntax-rule (with-shader-program shader-program body ...)
-  "Evaluate BODY with SHADER-PROGRAM bound."
-  (parameterize ((current-shader-program shader-program))
-    (begin
-      (apply-shader-program shader-program)
-      (let ((return-value (begin body ...)))
-        (glUseProgram 0)
-        return-value))))
+(define (apply-shader shader)
+  (glUseProgram (shader-id shader)))
 
 ;;;
 ;;; Uniforms
@@ -352,14 +330,14 @@ location."
                                          (color-b c)
                                          (color-a c))))
 
-(define (uniform-set! shader-program name value)
+(define (uniform-set! shader name value)
   "Use the appropriate setter procedure to translate VALUE into OpenGL
 compatible data and assign it to the location of the uniform NAME
-within SHADER-PROGRAM."
+within SHADER."
   (let ((setter (find (lambda (setter)
                         ((uniform-setter-predicate setter) value))
                       %uniform-setters))
-        (location (shader-program-uniform-location shader-program name)))
+        (location (shader-uniform-location shader name)))
     (if setter
         ((uniform-setter-proc setter) location value)
         (error "Not a valid uniform data type" value))))
@@ -372,9 +350,9 @@ within SHADER-PROGRAM."
 ;; an OpenGL context available.
 (define %default-shader
   (delay
-    (load-shader-program
+    (load-shader
      #:vertex-source (scope-datadir "/shaders/default-vertex.glsl")
-     #:fragment-source (scopre-datadir "/shaders/default-fragment.glsl")
+     #:fragment-source (scope-datadir "/shaders/default-fragment.glsl")
      #:uniforms `((mvp "mvp" ,identity-transform)
                   (color "color" ,white)
                   (texture? "use_texture" #f)))))