#lang racket

(provide scopes/c
         →scopes
         →scopes*
         (rename-out [→scopes ->scopes]
                     [→scopes* ->scopes*])
         empty-scopes
         empty-scopes-syntax
         scopes-add
         scopes-remove
         scopes-flip
         scopes-intersect
         (rename-out [scopes-flip scopes-symmetric-difference])
         single-scope?
         zero-scopes?
         scopes-equal?
         scope-kind
         use-site-scope?
         macro-scope?
         module-scope?
         intdef-scope?
         local-scope?
         top-scope?
         all-scopes-in?
         any-scope-in?)

(define scopes/c
  (->* (syntax?) ([or/c 'add 'remove 'flip]) syntax?))

(define/contract empty-scopes-syntax
  syntax?
  (datum->syntax #f 'zero))

(define/contract (→scopes stx)
  (-> syntax? scopes/c)
  (make-syntax-delta-introducer (datum->syntax stx 'stx)
                                empty-scopes-syntax))

(define/contract empty-scopes
  scopes/c
  (→scopes empty-scopes-syntax))

(define/contract (→scopes* stx)
  (-> (or/c syntax? scopes/c) scopes/c)
  (if (syntax? stx)
      (→scopes stx)
      stx))

(define/contract (scopes-add sc1 sc2)
  (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) scopes/c)
  (→scopes ((→scopes* sc1) ((→scopes* sc2) empty-scopes-syntax)
                           'add)))

(define/contract (scopes-remove sc1 sc2)
  (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) scopes/c)
  (→scopes ((→scopes* sc1) ((→scopes* sc2) empty-scopes-syntax)
                           'remove)))

(define/contract (scopes-flip sc1 sc2)
  (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) scopes/c)
  (→scopes ((→scopes* sc1) ((→scopes* sc2) empty-scopes-syntax)
                           'flip)))

(define/contract (scopes-intersect sc1 sc2)
  (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) scopes/c)
  (scopes-remove sc1 (scopes-remove sc1 sc2)))

#;(define/contract (scopes-symmetric-difference sc1 sc2)
    (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) scopes/c)
    (scopes-add (scopes-remove sc1 sc2)
                (scopes-remove sc2 sc1)))

(define/contract (single-scope? sc)
  (-> (or/c syntax? scopes/c) boolean?)
  (= (length (hash-ref (syntax-debug-info
                        ((→scopes* sc) empty-scopes-syntax))
                       'context))
     1))

(define/contract (zero-scopes? sc)
  (-> (or/c syntax? scopes/c) boolean?)
  (= (length (hash-ref (syntax-debug-info
                        ((→scopes* sc) empty-scopes-syntax))
                       'context))
     0))

(define/contract (scopes-equal? sc1 sc2)
  (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) boolean?)
  (bound-identifier=? ((→scopes* sc1) empty-scopes-syntax)
                      ((→scopes* sc2) empty-scopes-syntax)))

(define/contract (scope-kind sc)
  (-> (and/c (or/c syntax? scopes/c) single-scope?) symbol?)
  (define stx ((→scopes* sc) empty-scopes-syntax))
  (vector-ref (list-ref (hash-ref (syntax-debug-info stx) 'context) 0) 1))

(define/contract (use-site-scope? sc)
  (-> (and/c (or/c syntax? scopes/c) single-scope?) boolean?)
  (eq? (scope-kind sc) 'use-site))

(define/contract (macro-scope? sc)
  (-> (and/c (or/c syntax? scopes/c) single-scope?) boolean?)
  (eq? (scope-kind sc) 'macro))

(define/contract (module-scope? sc)
  (-> (and/c (or/c syntax? scopes/c) single-scope?) boolean?)
  (eq? (scope-kind sc) 'module))

(define/contract (intdef-scope? sc)
  (-> (and/c (or/c syntax? scopes/c) single-scope?) boolean?)
  (eq? (scope-kind sc) 'intdef))

(define/contract (local-scope? sc)
  (-> (and/c (or/c syntax? scopes/c) single-scope?) boolean?)
  (eq? (scope-kind sc) 'local))

;; This appears on the #'module identifier itself, when expanding a module
;; Run the macro stepper on an empty #lang racket program, and click on the
;; #'module identifier, then on the "syntax object" tab to see it.
;; (Stepper → View syntax properties to enable the "syntax object" tab).
(define/contract (top-scope? sc)
  (-> (and/c (or/c syntax? scopes/c) single-scope?) boolean?)
  (eq? (scope-kind sc) 'top))

(define/contract (all-scopes-in? sc1 sc2)
  (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) boolean?)
  (zero-scopes? (scopes-remove sc2 sc1)))

(define/contract (any-scope-in? sc1 sc2)
  (-> (or/c syntax? scopes/c) (or/c syntax? scopes/c) boolean?)
  (not (zero-scopes? (scopes-intersect sc1 sc2))))