#lang racket/base

(provide let/assert
         make-assert
         a-eq? a-!eq?
         a->? a-<=?
         a->=? a-<?
         a-=? a-!=?
         a-<0? a->=0?
         a-<=0? a->0?
         a-=0? a-!=0?
         a-true? a-false?
         a-nullptr? a-!nullptr?
         )

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; let/assert
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define-syntax make-assert
  (syntax-rules ()
    ((_ name not-name pred)
     (begin
       (define-syntax name
         (syntax-rules ()
           ((_ const)
            (λ (x) (pred x const)))))
       (define-syntax not-name
         (syntax-rules ()
           ((_ const)
            (λ (x) (not (pred x const))))))
       )
     )
    )
  )

(make-assert a-eq? a-!eq? eq?)

(define a-nullptr? (a-eq? #f))
(define a-!nullptr? (a-!eq? #f))

(make-assert a->? a-<=? >)
(make-assert a->=? a-<? >=)
(make-assert a-=? a-!=? =)

(define (a-=0? x) (= x 0))
(define (a-!=0? x) (not (= x 0)))
(define (a->0? x) (> x 0))
(define (a->=0? x) (>= x 0))
(define (a-<0? x) (< x 0))
(define (a-<=0? x) (<= x 0))


(define a-true? (a-eq? #t))
(define a-false? (a-eq? #f))

(struct exn:let/assert exn (value) #:transparent)

(define (raise-let/assert v)
  (raise (exn:let/assert "let/assert" (current-continuation-marks) v)))

(define (let/assert-value r)
  (exn:let/assert-value r))

(define-syntax assert-expr
  (syntax-rules ()
    ((_ expr cond retval)
     (let ((a expr)) (if (cond a) a (raise-let/assert retval))))
    ((_ expr)
     expr)
    )
  )

(define-syntax let/assert
  (syntax-rules ()
    ((_ ((v rest ...) ...) b1 ...)
     (with-handlers ([exn:let/assert? let/assert-value])
       (let* ((v (assert-expr rest ...))
              ...)
         b1
         ...
         )
       )
     )
    )
  )