From 08ffe848e6b3ac410277db520377493ee4881283 Mon Sep 17 00:00:00 2001
From: ben <benjaminlgreenman@gmail.com>
Date: Sun, 13 Mar 2016 00:43:58 -0500
Subject: [PATCH] [private] disallow set-bang in modules using trivial

---
 define.rkt           |  2 ++
 math.rkt             |  3 +++
 no-colon.rkt         |  2 ++
 private/db.rkt       |  4 ++++
 private/math.rkt     |  5 +++--
 private/regexp.rkt   |  5 +++--
 private/set-bang.rkt | 33 +++++++++++++++++++++++++++++++++
 regexp.rkt           |  6 +++++-
 test/define-fail.rkt | 13 +++++++++++++
 vector.rkt           |  2 ++
 10 files changed, 70 insertions(+), 5 deletions(-)
 create mode 100644 private/set-bang.rkt
 create mode 100644 test/define-fail.rkt

diff --git a/define.rkt b/define.rkt
index 2b74bb3..13d6cb0 100644
--- a/define.rkt
+++ b/define.rkt
@@ -2,9 +2,11 @@
 
 (provide
   define: let:
+  (all-from-out trivial/private/set-bang)
 )
 
 (require
+  trivial/private/set-bang
   (for-syntax
     trivial/private/common
     racket/base)
diff --git a/math.rkt b/math.rkt
index c4d10a5..bd28db3 100644
--- a/math.rkt
+++ b/math.rkt
@@ -11,8 +11,11 @@
   expt:
 
   define-num: let-num:
+
+  set!
 )
 
 (require
+  trivial/private/set-bang
   (only-in trivial/private/math
     +: -: *: /: expt: let-num: define-num:))
diff --git a/no-colon.rkt b/no-colon.rkt
index d4bbc6d..8f20a2b 100644
--- a/no-colon.rkt
+++ b/no-colon.rkt
@@ -4,6 +4,7 @@
 ;;  but without the trailing colon.
 
 (provide
+  set!
   (all-from-out trivial/define/no-colon)
   (all-from-out trivial/format/no-colon)
   (all-from-out trivial/function/no-colon)
@@ -12,6 +13,7 @@
   (all-from-out trivial/vector/no-colon))
 
 (require
+  trivial/private/set-bang
   trivial/define/no-colon
   trivial/format/no-colon
   trivial/function/no-colon
diff --git a/private/db.rkt b/private/db.rkt
index 43a0d9f..e3d7a3c 100644
--- a/private/db.rkt
+++ b/private/db.rkt
@@ -24,6 +24,10 @@
   ;; define schema
   ;; start connection
   ;; query-exec
+
+  ;; --
+  (for-syntax
+    connection-key)
 )
 
 ;; -----------------------------------------------------------------------------
diff --git a/private/math.rkt b/private/math.rkt
index 47cafe1..47875f4 100644
--- a/private/math.rkt
+++ b/private/math.rkt
@@ -18,6 +18,7 @@
     nat/expand
     int/expand
     num/expand
+    num-key
     num-define
     num-let)
 )
@@ -91,8 +92,8 @@
 
 ;; -----------------------------------------------------------------------------
 
-(define-syntax define-num: (make-keyword-alias 'define num-define))
-(define-syntax let-num: (make-keyword-alias 'let num-let))
+(define-syntax define-num: (make-keyword-alias #'define num-define))
+(define-syntax let-num: (make-keyword-alias #'let num-let))
 
 (define-syntax make-numeric-operator
   (syntax-parser
diff --git a/private/regexp.rkt b/private/regexp.rkt
index 22b2afc..4907a27 100644
--- a/private/regexp.rkt
+++ b/private/regexp.rkt
@@ -13,6 +13,7 @@
   regexp-match:
 
   (for-syntax
+    rx-key
     rx-define
     rx-let)
 )
@@ -108,7 +109,7 @@
   (define parse-groups/byte-pregexp
     parse-groups/byte-regexp)
 
-  (define-values (num-groups-key rx? rx-define rx-let)
+  (define-values (rx-key rx? rx-define rx-let)
     (make-value-property 'rx:groups parse-groups))
   (define-syntax-class/predicate pattern/groups rx?)
 )
@@ -126,7 +127,7 @@
            [(_ pat:pattern/groups)
             (syntax-property
               (syntax/loc stx (f* pat.expanded))
-              num-groups-key
+              rx-key
               #'pat.evidence)]
            [_ #f])))) ...)]))
 
diff --git a/private/set-bang.rkt b/private/set-bang.rkt
new file mode 100644
index 0000000..d73cdf8
--- /dev/null
+++ b/private/set-bang.rkt
@@ -0,0 +1,33 @@
+#lang typed/racket/base
+
+(provide
+  (rename-out [set!: set!])
+)
+
+(require
+  (for-syntax
+    racket/base
+    syntax/parse
+    trivial/private/common)
+  (only-in trivial/private/db connection-key)
+  (only-in trivial/private/math num-key)
+  (only-in trivial/private/regexp rx-key)
+  (only-in trivial/private/vector vector-length-key)
+)
+
+;; =============================================================================
+
+(define-for-syntax (has-important-syntax-property? stx)
+  (or #t)) ;; Safe over-approximation
+;   (syntax-property stx connection-key)
+;   (syntax-property stx num-key)
+;   (syntax-property stx rx-key)
+;   (syntax-property stx vector-length-key)))
+
+(define-syntax set!: (make-keyword-alias #'set!
+  (lambda (stx) (syntax-parse stx
+   [(_ name val)
+    #:when (has-important-syntax-property? #'name)
+    (raise-syntax-error 'trivial "mutation not allowed"); stx); #'name)
+    #'(void)]
+   [_ #f]))))
diff --git a/regexp.rkt b/regexp.rkt
index de12faf..5be22f5 100644
--- a/regexp.rkt
+++ b/regexp.rkt
@@ -3,6 +3,7 @@
 ;; Stronger types for regular expression matching.
 
 (provide
+  set!
   regexp:       define-regexp:       let-regexp:
   pregexp:
   byte-regexp:
@@ -20,4 +21,7 @@
   ;; Will raise a compile-time exception if the pattern contains unmatched groups.
 )
 
-(require trivial/private/regexp)
+(require
+  trivial/private/regexp
+  trivial/private/set-bang
+)
diff --git a/test/define-fail.rkt b/test/define-fail.rkt
new file mode 100644
index 0000000..a0e4ee7
--- /dev/null
+++ b/test/define-fail.rkt
@@ -0,0 +1,13 @@
+#lang racket/base
+(require trivial/private/test-common
+  (only-in typed/racket/base
+    ann Zero))
+
+(module+ test (test-compile-error
+  #:require trivial/math
+  #:exn #rx"mutation not allowed"
+
+  (let-num: ([n 5])
+    (set! n 6)
+    (ann (-: n 5) Zero))
+))
diff --git a/vector.rkt b/vector.rkt
index 286d6d5..e58e16f 100644
--- a/vector.rkt
+++ b/vector.rkt
@@ -1,6 +1,7 @@
 #lang typed/racket/base
 
 (provide
+  set!
   (all-from-out racket/vector)
 
   define-vector:
@@ -26,6 +27,7 @@
 
 (require
   racket/vector
+  trivial/private/set-bang
   (only-in trivial/private/vector
     define-vector:
     let-vector: