Remove a layer of nesting for shader globals.

5 files changed, 127 insertions, 128 deletions

diff --git a/chickadee/graphics/9-patch.scm b/chickadee/graphics/9-patch.scm
index 308cd65..21a5c18 100644
--- a/chickadee/graphics/9-patch.scm
+++ b/chickadee/graphics/9-patch.scm
@@ -42,24 +42,24 @@
 (define-graphics-variable 9-patch-margins (make-null-rect))
 
 (define-vertex-shader 9-patch-vertex
-  ((in vec2 position)
-   (in vec2 distance)
-   (out vec2 frag-distance)
-   (uniform mat4 mvp))
+  (in vec2 position)
+  (in vec2 distance)
+  (out vec2 frag-distance)
+  (uniform mat4 mvp)
   (outputs
    (vertex:position (* mvp (vec4 (-> position x) (-> position y) 0.0 1.0)))
    (frag-distance distance)))
 
 (define-fragment-shader 9-patch-fragment
-  ((in vec2 frag-distance)
-   (out vec4 frag-color)
-   (uniform vec4 subtexture)
-   (uniform vec4 margins)
-   (uniform float width)
-   (uniform float height)
-   (uniform sampler-2d color-texture)
-   (uniform vec4 tint)
-   (uniform int mode))
+  (in vec2 frag-distance)
+  (out vec4 frag-color)
+  (uniform vec4 subtexture)
+  (uniform vec4 margins)
+  (uniform float width)
+  (uniform float height)
+  (uniform sampler-2d color-texture)
+  (uniform vec4 tint)
+  (uniform int mode)
   (define (patch d m0 m1 length tex-length)
     (cond
      ;; Inside the left/bottom margin.
diff --git a/chickadee/graphics/particles.scm b/chickadee/graphics/particles.scm
index c9dd532..cd627bd 100644
--- a/chickadee/graphics/particles.scm
+++ b/chickadee/graphics/particles.scm
@@ -93,16 +93,16 @@ indefinitely."
   (acceleration vec2))
 
 (define-vertex-shader particles-vertex
-  ((in vec2 position)
-   (in vec2 tex)
-   (in vec2 offset)
-   (in float life)
-   (out vec2 frag-tex)
-   (out float frag-t)
-   (uniform mat4 mvp)
-   (uniform int lifetime)
-   (uniform int animation-rows)
-   (uniform int animation-columns))
+  (in vec2 position)
+  (in vec2 tex)
+  (in vec2 offset)
+  (in float life)
+  (out vec2 frag-tex)
+  (out float frag-t)
+  (uniform mat4 mvp)
+  (uniform int lifetime)
+  (uniform int animation-rows)
+  (uniform int animation-columns)
   (let* ((p (+ position offset))
          (t (/ life lifetime))
          (num-tiles (* animation-rows animation-columns))
@@ -119,12 +119,12 @@ indefinitely."
      (frag-t t))))
 
 (define-fragment-shader particles-fragment
-  ((in vec2 frag-tex)
-   (in float frag-t)
-   (out vec4 frag-color)
-   (uniform sampler-2d color-texture)
-   (uniform vec4 start-color)
-   (uniform vec4 end-color))
+  (in vec2 frag-tex)
+  (in float frag-t)
+  (out vec4 frag-color)
+  (uniform sampler-2d color-texture)
+  (uniform vec4 start-color)
+  (uniform vec4 end-color)
   (outputs
    (frag-color (* (mix end-color start-color frag-t)
                   (texture color-texture frag-tex)))))
diff --git a/chickadee/graphics/path.scm b/chickadee/graphics/path.scm
index 9c177b5..679995e 100644
--- a/chickadee/graphics/path.scm
+++ b/chickadee/graphics/path.scm
@@ -1222,13 +1222,13 @@
 ;;;
 
 (define-vertex-shader stroke-vertex
-  ((in vec2 position)
-   (in vec2 tex)
-   (in float stroke-length)
-   (out vec2 frag-tex)
-   (out float frag-stroke-length)
-   (uniform mat4 mvp)
-   (uniform vec4 color))
+  (in vec2 position)
+  (in vec2 tex)
+  (in float stroke-length)
+  (out vec2 frag-tex)
+  (out float frag-stroke-length)
+  (uniform mat4 mvp)
+  (uniform vec4 color)
   ;; Short-circuit because the fragments will just be discarded
   ;; anyway.
   (if (<= (-> color w) 0.0)
@@ -1240,15 +1240,15 @@
        (frag-stroke-length stroke-length))))
 
 (define-fragment-shader stroke-fragment
-  ((in vec2 frag-tex)
-   (in float frag-stroke-length)
-   (out vec4 frag-color)
-   (uniform vec4 color)
-   (uniform float feather)
-   (uniform int stroke-closed)
-   (uniform float stroke-width)
-   (uniform int stroke-cap)
-   (uniform float stroke-miter-limit))
+  (in vec2 frag-tex)
+  (in float frag-stroke-length)
+  (out vec4 frag-color)
+  (uniform vec4 color)
+  (uniform float feather)
+  (uniform int stroke-closed)
+  (uniform float stroke-width)
+  (uniform int stroke-cap)
+  (uniform float stroke-miter-limit)
   (if (<= (-> color w) 0.0)
       (discard)
       (let* ((infinity (/ 1.0 0.0))
@@ -1291,11 +1291,11 @@
   (compile-shader stroke-vertex stroke-fragment))
 
 (define-vertex-shader fill-vertex
-  ((in vec2 position)
-   (out vec2 frag-position)
-   (uniform mat4 mvp)
-   (uniform vec4 color)
-   (uniform mat3 gradient-matrix))
+  (in vec2 position)
+  (out vec2 frag-position)
+  (uniform mat4 mvp)
+  (uniform vec4 color)
+  (uniform mat3 gradient-matrix)
   ;; Short-circuit because the fragments will just be discarded
   ;; anyway.
   (if (<= (-> color w) 0.0)
@@ -1309,13 +1309,13 @@
          (frag-position (vec2 (-> fp x) (-> fp y)))))))
 
 (define-fragment-shader fill-fragment
-  ((in vec2 frag-position)
-   (out vec4 frag-color)
-   (uniform int mode)
-   (uniform vec4 color)
-   (uniform vec4 end-color)
-   (uniform vec2 gradient-range)
-   (uniform float radial-gradient-ratio))
+  (in vec2 frag-position)
+  (out vec4 frag-color)
+  (uniform int mode)
+  (uniform vec4 color)
+  (uniform vec4 end-color)
+  (uniform vec2 gradient-range)
+  (uniform float radial-gradient-ratio)
   (define (gradient-mix x)
     (let* ((start (-> gradient-range x))
            (end (-> gradient-range y))
diff --git a/chickadee/graphics/seagull.scm b/chickadee/graphics/seagull.scm
index 23cb7af..0434db3 100644
--- a/chickadee/graphics/seagull.scm
+++ b/chickadee/graphics/seagull.scm
@@ -339,24 +339,28 @@
           (loop `(array-ref ,prev ,(expand j stage env))
                 rest)))))))
 
-(define (expand:begin definitions body stage env)
-  (define bindings
-    (map (match-lambda
-           (('define (proc-name (? symbol? params) ...) body)
-            (list proc-name (expand `(lambda ,params ,body) stage env)))
-           (('define (? symbol? var-name) val)
-            (list var-name (expand val stage env)))
-           (invalid
-            (seagull-syntax-error "invalid definition" invalid expand:begin)))
-         definitions))
-  (define names (map first bindings))
-  (define env* (compose-envs (alpha-convert names) env))
-  (let loop ((bindings bindings))
-    (match bindings
-      (()
-       (expand body stage env*))
-      (((name value) . rest)
-       `(let ((,(lookup name env*) ,value)) ,(loop rest))))))
+(define (expand:begin body stage env)
+  (match body
+    (((and ('define _ ...) definitions) ... body)
+     (define bindings
+       (map (match-lambda
+              (('define (proc-name (? symbol? params) ...) body)
+               (list proc-name (expand `(lambda ,params ,body) stage env)))
+              (('define (? symbol? var-name) val)
+               (list var-name (expand val stage env)))
+              (invalid
+               (seagull-syntax-error "invalid definition" invalid expand:begin)))
+            definitions))
+     (define names (map first bindings))
+     (define env* (compose-envs (alpha-convert names) env))
+     (let loop ((bindings bindings))
+       (match bindings
+         (()
+          (expand body stage env*))
+         (((name value) . rest)
+          `(let ((,(lookup name env*) ,value)) ,(loop rest))))))
+    (_
+     (seagull-syntax-error "invalid begin form" `(begin ,@body) expand:begin))))
 
 ;; Arithmetic operators, in true Lisp fashion, can accept many
 ;; arguments.  + and * accept 0 or more. - and / accept one or more.
@@ -509,8 +513,8 @@
      (expand:-> exp members stage env))
     (('@ exp indices ...)
      (expand:@ exp indices stage env))
-    (('begin (and ('define _ ...) definitions) ... body)
-     (expand:begin definitions body stage env))
+    (('begin body ...)
+     (expand:begin body stage env))
     (('let* (bindings ...) body)
      (expand:let* bindings body stage env))
     (('+ args ...)
@@ -2719,33 +2723,14 @@
 (define (seagull-module-fragment? module)
   (eq? (seagull-module-stage module) 'fragment))
 
-(define (group-by-qualifier specs)
-  (let loop ((specs specs)
-             (inputs '())
-             (outputs '())
-             (uniforms '()))
-    (match specs
-      (()
-       `((inputs . ,(reverse inputs))
-         (outputs . ,(reverse outputs))
-         (uniforms . ,(reverse uniforms))))
-      ((spec . rest)
-       (match spec
-         (('in type-desc name)
-          (loop rest (cons spec inputs) outputs uniforms))
-         (('out type-desc name)
-          (loop rest inputs (cons spec outputs) uniforms))
-         (('uniform type-desc name)
-          (loop rest inputs outputs (cons spec uniforms))))))))
-
-(define* (compile-seagull #:key stage source
+(define* (compile-seagull #:key stage body
                           (inputs '()) (outputs '()) (uniforms '()))
   (unless (memq stage '(vertex fragment))
     (error "invalid shader stage" stage))
   (parameterize ((unique-identifier-counter 0)
                  (unique-variable-type-counter 0))
     (let ((source* `(top-level ,(append inputs outputs uniforms)
-                               ,source)))
+                               ,body)))
       (define-values (expanded global-map)
         (expand source* stage (top-level-env)))
       (let* ((simplified (simplify-exp expanded (empty-env)))
@@ -2760,39 +2745,53 @@
           (make-seagull-global qualifier type-desc name)))
        specs))
 
+(define (partition-globals exps)
+  (let loop ((exps exps)
+             (inputs '())
+             (outputs '())
+             (uniforms '()))
+    (match exps
+      (((and ('in _ _) spec) . rest)
+       (loop rest (cons spec inputs) outputs uniforms))
+      (((and ('out _ _) spec) . rest)
+       (loop rest inputs (cons spec outputs) uniforms))
+      (((and ('uniform _ _) spec) . rest)
+       (loop rest inputs outputs (cons spec uniforms)))
+      ((body ...)
+       (values (reverse inputs)
+               (reverse outputs)
+               (reverse uniforms)
+               `(begin ,@body))))))
+
 ;; Using syntax-case allows us to compile shaders to their fully typed
 ;; intermediate form at compile time, leaving only GLSL emission for
 ;; runtime.
 (define-syntax define-shader-stage
   (lambda (x)
     (syntax-case x ()
-      ((_ name stage ((qualifier type var) ...) source ...)
-       (let* ((globals (group-by-qualifier
-                        (syntax->datum
-                         #'((qualifier type var) ...))))
-              (inputs (assq-ref globals 'inputs))
-              (outputs (assq-ref globals 'outputs))
-              (uniforms (assq-ref globals 'uniforms))
-              (source* #'(begin source ...)))
+      ((_ name stage body ...)
+       (let*-values (((inputs outputs uniforms body)
+                      (partition-globals
+                       (syntax->datum #'(body ...)))))
          (define-values (compiled global-map max-id)
            (compile-seagull #:stage (syntax->datum #'stage)
-                            #:source (syntax->datum source*)
                             #:inputs inputs
                             #:outputs outputs
-                            #:uniforms uniforms))
+                            #:uniforms uniforms
+                            #:body body))
          (with-syntax ((inputs (datum->syntax x inputs))
                        (outputs (datum->syntax x outputs))
                        (uniforms (datum->syntax x uniforms))
                        (compiled (datum->syntax x compiled))
                        (global-map (datum->syntax x global-map))
                        (max-id (datum->syntax x max-id))
-                       (source (datum->syntax x source*)))
+                       (body (datum->syntax x body)))
            #'(define name
                (make-seagull-module #:stage 'stage
                                     #:inputs (specs->globals 'inputs)
                                     #:outputs (specs->globals 'outputs)
                                     #:uniforms (specs->globals 'uniforms)
-                                    #:source 'source
+                                    #:source 'body
                                     #:compiled 'compiled
                                     #:global-map 'global-map
                                     #:max-id max-id))))))))
diff --git a/chickadee/graphics/sprite.scm b/chickadee/graphics/sprite.scm
index 118c572..414738d 100644
--- a/chickadee/graphics/sprite.scm
+++ b/chickadee/graphics/sprite.scm
@@ -58,19 +58,19 @@
 (define-graphics-variable sprite-mvp-matrix (make-null-matrix4))
 
 (define-vertex-shader sprite-vertex
-  ((in vec2 position)
-   (in vec2 tex)
-   (out vec2 frag-tex)
-   (uniform mat4 mvp))
+  (in vec2 position)
+  (in vec2 tex)
+  (out vec2 frag-tex)
+  (uniform mat4 mvp)
   (outputs
    (vertex:position (* mvp (vec4 (-> position x) (-> position y) 0.0 1.0)))
    (frag-tex tex)))
 
 (define-fragment-shader sprite-fragment
-  ((in vec2 frag-tex)
-   (out vec4 frag-color)
-   (uniform sampler-2d color-texture)
-   (uniform vec4 tint))
+  (in vec2 frag-tex)
+  (out vec4 frag-color)
+  (uniform sampler-2d color-texture)
+  (uniform vec4 tint)
   (outputs
    (frag-color (* (texture color-texture frag-tex) tint))))
 
@@ -165,22 +165,22 @@ BLEND-MODE."
   (tint vec4))
 
 (define-vertex-shader sprite-batch-vertex
-  ((in vec2 position)
-   (in vec2 tex)
-   (in vec4 tint)
-   (out vec2 frag-tex)
-   (out vec4 frag-tint)
-   (uniform mat4 mvp))
+  (in vec2 position)
+  (in vec2 tex)
+  (in vec4 tint)
+  (out vec2 frag-tex)
+  (out vec4 frag-tint)
+  (uniform mat4 mvp)
   (outputs
    (vertex:position (* mvp (vec4 (-> position x) (-> position y) 0.0 1.0)))
    (frag-tex tex)
    (frag-tint tint)))
 
 (define-fragment-shader sprite-batch-fragment
-  ((in vec2 frag-tex)
-   (in vec4 frag-tint)
-   (out vec4 frag-color)
-   (uniform sampler-2d color-texture))
+  (in vec2 frag-tex)
+  (in vec4 frag-tint)
+  (out vec4 frag-color)
+  (uniform sampler-2d color-texture)
   (outputs
    (frag-color (* (texture color-texture frag-tex) frag-tint))))