From 5387bd6e2b370a351646d15425b97754ebf7fa6a Mon Sep 17 00:00:00 2001
From: Jack Firth <jackhfirth@gmail.com>
Date: Thu, 14 Apr 2022 21:19:29 -0700
Subject: [PATCH] Add semantic actions for other kinds of objects

---
 base/derivation.rkt      | 216 ++++++++++++++++++++++++++----------
 base/semantic-action.rkt | 231 ++++++++++++++++++++++++++++++++++++++-
 2 files changed, 387 insertions(+), 60 deletions(-)

diff --git a/base/derivation.rkt b/base/derivation.rkt
index eed4517..7158915 100644
--- a/base/derivation.rkt
+++ b/base/derivation.rkt
@@ -139,73 +139,37 @@
 
 
 (define (parser-derivation->syntax derivation)
+  (define first-token (parser-derivation-first-terminal derivation))
+  (define last-token (parser-derivation-last-terminal derivation))
+
   (define (->splice derivation)
     (match derivation
       [(terminal-derivation t) (list (syntax-token->syntax t))]
-      [(nonterminal-derivation (? cut-action?) _) '()]
-      [(nonterminal-derivation (? splice-action?) children)
-       (for*/list ([child (in-vector children)]
-                   [stx (in-list (->splice child))])
-         stx)]
-      [(nonterminal-derivation (? label-action? label) children)
-       (define first-token (parser-derivation-first-terminal derivation))
-       (define label-location
-         (srcloc (syntax-token-source first-token)
-                 (syntax-token-line first-token)
-                 (syntax-token-column first-token)
-                 (syntax-token-position first-token)
-                 0))
-       (define label-stx
-         (for/fold ([stx (datum->syntax #false (label-action-value label) label-location #false)])
-                   ([(key value) (in-hash (label-action-properties label))])
-           (syntax-property stx key value)))
+      [(nonterminal-derivation action children)
        (define children-syntaxes
          (for*/list ([child (in-vector children)]
                      [spliced-child (in-list (->splice child))])
            spliced-child))
-       (define last-token (parser-derivation-last-terminal derivation))
-       (define expression-location
-         (srcloc (syntax-token-source first-token)
-                 (syntax-token-line first-token)
-                 (syntax-token-column first-token)
-                 (syntax-token-position first-token)
-                 (- (syntax-token-end-position last-token) (syntax-token-position first-token))))
-       (define expression-stx
-         (datum->syntax #false (cons label-stx children-syntaxes) expression-location #false))
-       (list (for/fold ([expression-stx expression-stx])
-                       ([(key value) (in-hash (label-action-expression-properties label))])
-               (syntax-property expression-stx key value)))]))
-  (define first-token (parser-derivation-first-terminal derivation))
-  (define last-token (parser-derivation-last-terminal derivation))
-  (define top-level-location
-    (srcloc (syntax-token-source first-token)
-            (syntax-token-line first-token)
-            (syntax-token-column first-token)
-            (syntax-token-position first-token)
-            (- (syntax-token-end-position last-token) (syntax-token-position first-token))))
-  (define top-level-stxs (->splice derivation))
-  (match top-level-stxs
+       (semantic-action-build-syntax-splice
+        action children-syntaxes #:first-token first-token #:last-token last-token)]))
+  
+  (match (->splice derivation)
     [(list stx) stx]))
 
 
 (define (parser-derivation->datum derivation)
+
   (define (->splice derivation)
     (match derivation
       [(terminal-derivation t) (list t)]
-      [(nonterminal-derivation (? cut-action?) _) '()]
-      [(nonterminal-derivation (? splice-action?) children)
-       (for*/list ([child (in-vector children)]
-                   [datum (in-list (->splice child))])
-         datum)]
-      [(nonterminal-derivation (? label-action? label) children)
-       (define value (label-action-value label))
+      [(nonterminal-derivation action children)
        (define child-data
          (for*/list ([child (in-vector children)]
-                     [spliced-child (in-list (->splice child))])
-           spliced-child))
-       (list (cons value child-data))]))
-  (define top-level-data (->splice derivation))
-  (match top-level-data
+                     [datum (in-list (->splice child))])
+           datum))
+       (semantic-action-build-datum-splice action child-data)]))
+  
+  (match (->splice derivation)
     [(list datum) datum]))
 
 
@@ -216,7 +180,7 @@
       (define derivation (parser-derivation 'a))
       (check-equal? (parser-derivation->datum derivation) 'a))
 
-    (test-case "datum nonterminals"
+    (test-case "datum labels"
       (define derivation
         (parser-derivation (label-action 'a)
                            (parser-derivation 'b)
@@ -241,7 +205,66 @@
                                               (parser-derivation 'c2)
                                               (parser-derivation 'c3))
                            (parser-derivation 'd)))
-      (check-equal? (parser-derivation->datum derivation) '(a b c1 c2 c3 d))))
+      (check-equal? (parser-derivation->datum derivation) '(a b c1 c2 c3 d)))
+
+    (test-case "datum pairs"
+      (define derivation
+        (parser-derivation (build-pair-action) (parser-derivation 'b) (parser-derivation 'c)))
+      (check-equal? (parser-derivation->datum derivation) '(b . c)))
+
+    (test-case "datum lists"
+      (define derivation
+        (parser-derivation (build-list-action)
+                           (parser-derivation 'b)
+                           (parser-derivation 'c)
+                           (parser-derivation 'd)))
+      (check-equal? (parser-derivation->datum derivation) '(b c d)))
+
+    (test-case "improper datum lists"
+      (define derivation
+        (parser-derivation (build-improper-list-action)
+                           (parser-derivation 'b)
+                           (parser-derivation 'c)
+                           (parser-derivation 'd)))
+      (check-equal? (parser-derivation->datum derivation) '(b c . d)))
+
+    (test-case "datum vectors"
+      (define derivation
+        (parser-derivation (build-vector-action)
+                           (parser-derivation 'b)
+                           (parser-derivation 'c)
+                           (parser-derivation 'd)))
+      (check-equal? (parser-derivation->datum derivation) #(b c d)))
+
+    (test-case "datum hashes"
+      (define derivation
+        (parser-derivation (build-hash-action)
+                           (parser-derivation 'a)
+                           (parser-derivation 1)
+                           (parser-derivation 'b)
+                           (parser-derivation 2)))
+      (check-equal? (parser-derivation->datum derivation) (hash 'a 1 'b 2)))
+
+    (test-case "datum hashes with duplicate keys"
+      (define derivation
+        (parser-derivation (build-hash-action)
+                           (parser-derivation 'a)
+                           (parser-derivation 1)
+                           (parser-derivation 'a)
+                           (parser-derivation 2)))
+      (check-exn exn:fail:contract? (λ () (parser-derivation->datum derivation))))
+
+    (test-case "datum boxes"
+      (define derivation
+        (parser-derivation (build-box-action) (parser-derivation 'a)))
+      (check-equal? (parser-derivation->datum derivation) (box-immutable 'a)))
+
+    (test-case "prefab datum structs"
+      (define derivation
+        (parser-derivation (build-prefab-struct-action 'point)
+                           (parser-derivation 1)
+                           (parser-derivation 2)))
+      (check-equal? (parser-derivation->datum derivation) #s(point 1 2))))
 
   (test-case (name-string parser-derivation->syntax)
 
@@ -251,7 +274,7 @@
       (check-equal? (syntax->datum actual) 'a)
       (check-equal? (syntax-srcloc actual) (srcloc #false #false #false 1 1)))
 
-    (test-case "syntax nonterminals"
+    (test-case "syntax labels"
       (define derivation
         (parser-derivation
          (label-action 'a)
@@ -285,4 +308,87 @@
          (parser-derivation (syntax-token 'd #:position 5 #:span 1))))
       (define actual (parser-derivation->syntax derivation))
       (check-equal? (syntax->datum actual) '(a b c1 c2 c3 d))
-      (check-equal? (syntax-srcloc actual) (srcloc #false #false #false 1 5)))))
+      (check-equal? (syntax-srcloc actual) (srcloc #false #false #false 1 5)))
+
+    (test-case "syntax pairs"
+      (define derivation
+        (parser-derivation
+         (build-pair-action)
+         (parser-derivation (syntax-token 'b #:position 1 #:span 1))
+         (parser-derivation (syntax-token 'c #:position 2 #:span 1))))
+      (define actual (parser-derivation->syntax derivation))
+      (check-equal? (syntax->datum actual) '(b . c))
+      (check-equal? (syntax-srcloc actual) (srcloc #false #false #false 1 2)))
+
+    (test-case "syntax lists"
+      (define derivation
+        (parser-derivation
+         (build-list-action)
+         (parser-derivation (syntax-token 'b #:position 1 #:span 1))
+         (parser-derivation (syntax-token 'c #:position 2 #:span 1))
+         (parser-derivation (syntax-token 'd #:position 3 #:span 1))))
+      (define actual (parser-derivation->syntax derivation))
+      (check-equal? (syntax->datum actual) '(b c d))
+      (check-equal? (syntax-srcloc actual) (srcloc #false #false #false 1 3)))
+
+    (test-case "improper syntax lists"
+      (define derivation
+        (parser-derivation
+         (build-improper-list-action)
+         (parser-derivation (syntax-token 'b #:position 1 #:span 1))
+         (parser-derivation (syntax-token 'c #:position 2 #:span 1))
+         (parser-derivation (syntax-token 'd #:position 3 #:span 1))))
+      (define actual (parser-derivation->syntax derivation))
+      (check-equal? (syntax->datum actual) '(b c . d))
+      (check-equal? (syntax-srcloc actual) (srcloc #false #false #false 1 3)))
+
+    (test-case "syntax vectors"
+      (define derivation
+        (parser-derivation
+         (build-vector-action)
+         (parser-derivation (syntax-token 'b #:position 1 #:span 1))
+         (parser-derivation (syntax-token 'c #:position 2 #:span 1))
+         (parser-derivation (syntax-token 'd #:position 3 #:span 1))))
+      (define actual (parser-derivation->syntax derivation))
+      (check-equal? (syntax->datum actual) #(b c d))
+      (check-equal? (syntax-srcloc actual) (srcloc #false #false #false 1 3)))
+
+    (test-case "syntax hash tables"
+      (define derivation
+        (parser-derivation
+         (build-hash-action)
+         (parser-derivation (syntax-token 'a #:position 1 #:span 1))
+         (parser-derivation (syntax-token 1 #:position 2 #:span 1))
+         (parser-derivation (syntax-token 'b #:position 3 #:span 1))
+         (parser-derivation (syntax-token 2 #:position 4 #:span 1))))
+      (define actual (parser-derivation->syntax derivation))
+      (check-equal? (syntax->datum actual) (hash 'a 1 'b 2))
+      (check-equal? (syntax-srcloc actual) (srcloc #false #false #false 1 4)))
+
+    (test-case "syntax hash tables with duplicate keys"
+      (define derivation
+        (parser-derivation
+         (build-hash-action)
+         (parser-derivation (syntax-token 'a #:position 1 #:span 1))
+         (parser-derivation (syntax-token 1 #:position 2 #:span 1))
+         (parser-derivation (syntax-token 'a #:position 3 #:span 1))
+         (parser-derivation (syntax-token 2 #:position 4 #:span 1))))
+      (check-exn exn:fail:contract? (λ () (parser-derivation->syntax derivation))))
+
+    (test-case "syntax boxes"
+      (define derivation
+        (parser-derivation
+         (build-box-action) (parser-derivation (syntax-token 'a #:position 1 #:span 1))))
+      (define actual (parser-derivation->syntax derivation))
+      (check-equal? (syntax->datum actual) (box-immutable 'a))
+      (check-equal? (syntax-srcloc actual) (srcloc #false #false #false 1 1)))
+
+    (test-case "prefab syntax structs"
+      (define derivation
+        (parser-derivation
+         (build-prefab-struct-action 'point)
+         (parser-derivation (syntax-token 5 #:position 1 #:span 1))
+         (parser-derivation (syntax-token 10 #:position 2 #:span 1))))
+      (define actual (parser-derivation->syntax derivation))
+      (check-equal? (syntax->datum actual) #s(point 5 10))
+      (check-equal? (syntax-srcloc actual) (srcloc #false #false #false 1 2)))))
diff --git a/base/semantic-action.rkt b/base/semantic-action.rkt
index 41f82c1..0fc9023 100644
--- a/base/semantic-action.rkt
+++ b/base/semantic-action.rkt
@@ -7,6 +7,10 @@
 (provide
  (contract-out
   [semantic-action? predicate/c]
+  [semantic-action-build-datum-splice (-> semantic-action? list? list?)]
+  [semantic-action-build-syntax-splice
+   (-> semantic-action? (listof syntax?) #:first-token syntax-token? #:last-token syntax-token?
+       (listof syntax?))]
   [cut-action cut-action?]
   [cut-action? predicate/c]
   [splice-action splice-action?]
@@ -15,13 +19,26 @@
   [label-action (->* (any/c) (#:properties hash? #:expression-properties hash?) label-action?)]
   [label-action-value (-> label-action? any/c)]
   [label-action-properties (-> label-action? hash?)]
-  [label-action-expression-properties (-> label-action? hash?)]))
+  [label-action-expression-properties (-> label-action? hash?)]
+  [build-pair-action (->* () (#:properties hash?) build-pair-action?)]
+  [build-pair-action? predicate/c]
+  [build-list-action (->* () (#:properties hash?) build-list-action?)]
+  [build-list-action? predicate/c]
+  [build-improper-list-action (->* () (#:properties hash?) build-improper-list-action?)]
+  [build-improper-list-action? predicate/c]
+  [build-vector-action (->* () (#:properties hash?) build-vector-action?)]
+  [build-vector-action? predicate/c]
+  [build-hash-action (->* () (#:kind (or/c 'equal 'eqv 'eq) #:properties hash?) build-hash-action?)]
+  [build-hash-action? predicate/c]
+  [build-box-action (->* () (#:properties hash?) build-box-action?)]
+  [build-box-action? predicate/c]
+  [build-prefab-struct-action (->* (prefab-key?) (#:properties hash?) build-prefab-struct-action?)]
+  [build-prefab-struct-action? predicate/c]))
 
 
-(require racket/match
+(require racket/list
+         racket/match
          racket/sequence
-         racket/struct
-         rebellion/collection/vector
          rebellion/private/static-name
          yaragg/base/token)
 
@@ -30,7 +47,16 @@
 
 
 (define (semantic-action? v)
-  (or (cut-action? v) (splice-action? v) (label-action? v)))
+  (or (cut-action? v)
+      (splice-action? v)
+      (label-action? v)
+      (build-pair-action? v)
+      (build-list-action? v)
+      (build-improper-list-action? v)
+      (build-vector-action? v)
+      (build-hash-action? v)
+      (build-box-action? v)
+      (build-prefab-struct-action? v)))
 
 
 (struct cut-action () #:transparent #:constructor-name constructor:cut-action #:omit-define-syntaxes)
@@ -56,3 +82,198 @@
                       #:properties [properties (hash)]
                       #:expression-properties [expression-properties (hash)])
   (constructor:label-action value properties expression-properties))
+
+
+(struct build-pair-action (properties)
+  #:transparent
+  #:constructor-name constructor:build-pair-action
+  #:omit-define-syntaxes)
+
+
+(define (build-pair-action #:properties [properties (hash)])
+  (constructor:build-pair-action properties))
+
+
+(struct build-list-action (properties)
+  #:transparent
+  #:constructor-name constructor:build-list-action
+  #:omit-define-syntaxes)
+
+
+(define (build-list-action #:properties [properties (hash)])
+  (constructor:build-list-action properties))
+
+
+(struct build-improper-list-action (properties)
+  #:transparent
+  #:constructor-name constructor:build-improper-list-action
+  #:omit-define-syntaxes)
+
+
+(define (build-improper-list-action #:properties [properties (hash)])
+  (constructor:build-improper-list-action properties))
+
+
+(struct build-vector-action (properties)
+  #:transparent
+  #:constructor-name constructor:build-vector-action
+  #:omit-define-syntaxes)
+
+
+(define (build-vector-action #:properties [properties (hash)])
+  (constructor:build-vector-action properties))
+
+
+(struct build-hash-action (kind properties)
+  #:transparent
+  #:constructor-name constructor:build-hash-action
+  #:omit-define-syntaxes)
+
+
+(define (build-hash-action #:kind [kind 'equal] #:properties [properties (hash)])
+  (constructor:build-hash-action kind properties))
+
+
+(struct build-box-action (properties)
+  #:transparent
+  #:constructor-name constructor:build-box-action
+  #:omit-define-syntaxes)
+
+
+(define (build-box-action #:properties [properties (hash)])
+  (constructor:build-box-action properties))
+
+
+(struct build-prefab-struct-action (key properties)
+  #:transparent
+  #:constructor-name constructor:build-prefab-struct-action
+  #:omit-define-syntaxes)
+
+
+(define (build-prefab-struct-action key #:properties [properties (hash)])
+  (constructor:build-prefab-struct-action key properties))
+
+
+(define (semantic-action-build-datum-splice action children)
+  (match action
+    [(== cut-action) '()]
+    [(== splice-action) children]
+    [(? label-action?) (list (cons (label-action-value action) children))]
+    [(? build-pair-action?) (list (cons (first children) (second children)))]
+    [(? build-list-action?) (list children)]
+    [(? build-improper-list-action?) (list (list->improper-list children))]
+    [(? build-vector-action?) (list (list->vector children))]
+    [(? build-hash-action?)
+     (define hash-maker
+       (case (build-hash-action-kind action)
+         [(equal) make-immutable-hash]
+         [(eqv) make-immutable-hasheqv]
+         [(eq) make-immutable-hasheq]))
+     (define pairs
+       (for/list ([key+value (in-slice 2 children)])
+         (cons (first key+value) (second key+value))))
+     (define hash (hash-maker pairs))
+     (unless (equal? (hash-count hash) (length pairs))
+       (raise-arguments-error (name build-hash-action)
+                              "duplicate keys detected when building hash datum"
+                              "pairs" pairs))
+     (list hash)]
+    [(? build-box-action?) (list (box-immutable (first children)))]
+    [(? build-prefab-struct-action?)
+     (define key (build-prefab-struct-action-key action))
+     (list (apply make-prefab-struct key children))]))
+
+
+(define (semantic-action-build-syntax-splice action children
+                                             #:first-token first-token
+                                             #:last-token last-token)
+  (match action
+    [(== cut-action) '()]
+    [(== splice-action) children]
+
+    [(? label-action?)
+     (define label-location
+       (srcloc (syntax-token-source first-token)
+               (syntax-token-line first-token)
+               (syntax-token-column first-token)
+               (syntax-token-position first-token)
+               0))
+     (define label-stx
+       (syntax-add-properties
+        (datum->syntax #false (label-action-value action) label-location #false)
+        (label-action-properties action)))
+     (define expression-location (srcloc-spanning-tokens first-token last-token))
+     (define expression-stx
+       (datum->syntax #false (cons label-stx children) expression-location #false))
+     (list (syntax-add-properties expression-stx (label-action-expression-properties action)))]
+
+    [(? build-pair-action?)
+     (define location (srcloc-spanning-tokens first-token last-token))
+     (define properties (build-pair-action-properties action))
+     (define stx (datum->syntax #false (cons (first children) (second children)) location #false))
+     (list (syntax-add-properties stx properties))]
+
+    [(? build-list-action?)
+     (define location (srcloc-spanning-tokens first-token last-token))
+     (define properties (build-list-action-properties action))
+     (list (syntax-add-properties (datum->syntax #false children location #false) properties))]
+
+    [(? build-improper-list-action?)
+     (define location (srcloc-spanning-tokens first-token last-token))
+     (define properties (build-improper-list-action-properties action))
+     (define stx (datum->syntax #false (list->improper-list children) location #false))
+     (list (syntax-add-properties stx properties))]
+
+    [(? build-vector-action?)
+     (define location (srcloc-spanning-tokens first-token last-token))
+     (define properties (build-vector-action-properties action))
+     (define stx (datum->syntax #false (list->vector children) location #false))
+     (list (syntax-add-properties stx properties))]
+
+    [(? build-hash-action?)
+     (define location (srcloc-spanning-tokens first-token last-token))
+     (define hash-maker
+       (case (build-hash-action-kind action)
+         [(equal) make-immutable-hash]
+         [(eqv) make-immutable-hasheqv]
+         [(eq) make-immutable-hasheq]))
+     (define pairs
+       (for/list ([key+value (in-slice 2 children)])
+         (cons (syntax->datum (first key+value)) (second key+value))))
+     (define hash (hash-maker pairs))
+     (unless (equal? (hash-count hash) (length pairs))
+       (raise-arguments-error (name build-hash-action)
+                              "duplicate keys detected when building hash syntax"
+                              "pairs" pairs))
+     (define stx (datum->syntax #false (hash-maker pairs) location #false))
+     (list (syntax-add-properties stx (build-hash-action-properties action)))]
+
+    [(? build-box-action?)
+     (define location (srcloc-spanning-tokens first-token last-token))
+     (define properties (build-box-action-properties action))
+     (define stx (datum->syntax #false (box-immutable (first children)) location #false))
+     (list (syntax-add-properties stx properties))]
+
+    [(? build-prefab-struct-action?)
+     (define location (srcloc-spanning-tokens first-token last-token))
+     (define key (build-prefab-struct-action-key action))
+     (define properties (build-prefab-struct-action-properties action))
+     (define stx (datum->syntax #false (apply make-prefab-struct key children) location #false))
+     (list (syntax-add-properties stx properties))]))
+
+
+(define (list->improper-list list)
+  (apply list* list))
+
+
+(define (srcloc-spanning-tokens first-token last-token)
+  (srcloc (syntax-token-source first-token)
+          (syntax-token-line first-token)
+          (syntax-token-column first-token)
+          (syntax-token-position first-token)
+          (- (syntax-token-end-position last-token) (syntax-token-position first-token))))
+
+
+(define (syntax-add-properties stx properties)
+  (for/fold ([stx stx]) ([(key value) (in-hash properties)])
+    (syntax-property stx key value)))