#lang racket

(provide
  true false
  let parallel-let
  alias aliasλ aliased? value
  define-alias define-by-alias
  alias? ; is operand an alias?
  unalias ; evaluates operand if it's an alias?, else returns #f
  ; mpair? mcons mcar mcdr set-mcar! set-mcdr!
  mlist set-head!
  pair cons head tail
  egal?)

(require (only-in racket/base (let parallel-let))
         ; (for-syntax (only-in racket/base (let parallel-let)))
         (only-in racket/bool true false)
         (only-in compatibility/mlist mlist)
         (only-in racket/base (cons pair)))

(define (head xs) (if (mpair? xs) (mcar xs) (car xs)))
(define (tail xs) (if (mpair? xs) (mcdr xs) (cdr xs)))
(define set-head! set-mcar!)
(define (cons x xs)
  (cond
    [(mpair? xs) (mcons x xs)]
    [(pair? xs) (pair x xs)]
    [(null? xs) (pair x xs)]
    [else (raise-arguments-error 'cons "can only cons onto () or a mutable or immutable pair" "xs" xs)]))

(define (value x) x)
(define aliasλ (void))
(define alias-sentinel void)

; recursive macro
(define-syntax let
  (syntax-rules (aliasλ)
    [(_ bindings)
     (raise-syntax-error #f "bad syntax (missing body)" #'(let bindings))]
    [(_ ([id (aliasλ parms abody0 abody ...)] bindings ...) body ...)
     #;(begin
       (do-define-by-alias id parms () () abody0 abody ...)
       (let (bindings ...) body ...))
     (do-let-by-alias id parms () () (abody0 abody ...) (let (bindings ...) body ...))]
    [(_ ([id expr] bindings ...) body ...)
     (let* ([id expr]) (let (bindings ...) body ...))]
    [(_ () body ...)
     (let* () body ...)]))

; recursive function
(define (egal? x y)
  (cond
    [(eq? x y) #t]
    [(or (number? x) (number? y)) (eqv? x y)]
    [(or (char? x) (char? y)) (eqv? x y)]
    [(pair? x) (and (pair? y)
                    (egal? (car x) (car y))
                    (egal? (cdr x) (cdr y)))] ; no checking for reference cycles
    [(immutable? x)
     (and (immutable? y)
          (cond
            [(string? x) (equal? x y)]
            [(bytes? x) (equal? x y)]
            [(box? x) (and (box? y)
                           (egal? (unbox x) (unbox y)))]
            [(vector? x) (and (vector? y)
                              (for/and ([i x] [j y]) (egal? i j)))]
            [(hash? x) (and (hash? y)
                            (raise-arguments-error 'egal? "comparing immutable hashes not implemented" "x" x "y" y))]
            [else (error 'unreachable)]))]
    [(struct? x) ; will only be true if some fields are exposed
     (and (struct? y)
          ; compare as vectors
          (for/and ([i (struct->vector x)] [j (struct->vector y)]) (egal? i j)))]
    [else #f]))

; k can be one of: type/#f get/0 1 2
(define-syntax-rule (alias-handler id k arg else ...)
  (let* ([orig id]
         [tmp (set! id (alias-sentinel k arg))])
    (if (void? tmp) (begin (set! id orig) else ...) tmp)))

(define-for-syntax (make-alias id orig)
  #`(syntax-id-rules (set! alias-sentinel)
    [(set! #,id (alias-sentinel #f #f)) #t]
    [(set! #,id (alias-sentinel 0 #f)) (alias-handler #,orig 0 #f #,orig)]
    ; special handling for aliased?
    [(set! #,id (alias-sentinel 1 id2))
     (alias-handler #,orig 1 id2 (alias-handler id2 2 #,orig (do-aliased? #,orig id2)))]
    [(set! #,id (alias-sentinel 2 id1))
     (alias-handler #,orig 2 id1 (aliased? #,orig id1))]
    [(set! #,id e) (set! #,orig e)]
    ; the following is in fact redundant, given the last clause
    ; [(id a (... ...)) (((lambda () #,orig)) a (... ...))]
    [#,id #,orig]))

(define-syntax alias
  (syntax-rules ()
    [(_ bindings)
     (raise-syntax-error #f "bad syntax (missing body)" #'(alias bindings))]
    [(_ ([id orig] ...) body ...)
     (do-alias* ([id orig] ...) body ...)]))

; recursive macro
(define-syntax (do-alias* stx)
  (syntax-case stx (value)
    [(_ ([id0 (value expr0)] [id orig] ...) body ...)
     #`(let* ([id0 expr0]) (do-alias* ([id orig] ...) body ...))]
    [(_ ([id0 orig0] [id orig] ...) body ...)
     (if (identifier? #'orig0)
         #`(let-syntax ([id0 #,(make-alias #'id0 (syntax-disarm (local-expand #'orig0 'expression #f) #f))]) (do-alias* ([id orig] ...) body ...))
         (raise-syntax-error #f "not an identifier" stx #'orig0))]
    [(_ () body ...)
     (syntax-protect #'(let-syntax () body ...))]))

; recursive macro
(define-syntax (do-alias stx)
  (syntax-case stx (value)
    [(_ ([id0 (value expr0)] [id orig] ...) (ids ...) (trs ...) (vids ...) (vexprs ...) body ...)
     #`(do-alias ([id orig] ...) (ids ... newid) (trs ... (lambda (_) #'expr0)) (vids ... id0) (vexprs ... newid) body ...)]
    [(_ ([id0 orig0] [id orig] ...) (ids ...) (trs ...) (vids ...) (vexprs ...) body ...)
     (if (identifier? #'orig0)
         #`(do-alias ([id orig] ...) (ids ... id0) (trs ... #,(make-alias #'id0 (syntax-disarm (local-expand #'orig0 'expression #f) #f))) (vids ...) (vexprs ...) body ...)
         (raise-syntax-error #f "not an identifier" stx #'orig0))]
    [(_ () (id ...) (trans ...) (vid ...) (vexpr ...) body ...)
     (syntax-protect #'(let-syntax ([id trans] ...) (let ([vid vexpr] ...) body ...)))]))

(define-syntax (define-alias stx)
  (syntax-case stx ()
    [(_ id orig)
     (syntax-protect #`(define-syntax id #,(make-alias #'id (syntax-disarm (local-expand #'orig 'expression #f) #f))))]))

(define-syntax-rule (define-by-alias (f id0 id ...) body0 body ...)
  (do-define-by-alias f (id0 id ...) () () body0 body ...))

; recursive macro
(define-syntax do-define-by-alias
  (syntax-rules ()
    [(_ f (id0 id ...) (ids ...) (origs ...) body ...)
     (do-define-by-alias f (id ...) (ids ... id0) (origs ... orig0) body ...)]
    [(_ f () (id ...) (orig ...) body ...)
     (define-syntax-rule (f orig ...)
       (do-alias ([id orig] ...) () () () () body ...))]))

; recursive macro
(define-syntax do-let-by-alias
  (syntax-rules ()
    [(_ f (id0 id ...) (ids ...) (origs ...) (abody ...) body ...)
     (do-let-by-alias f (id ...) (ids ... id0) (origs ... orig0) (abody ...) body ...)]
    [(_ f () (id ...) (orig ...) (abody ...) body ...)
     (let-syntax ([f (syntax-rules ()
                       [(_ orig ...)
                        (do-alias ([id orig] ...) () () () () abody ...)])])
       body ...)]))

(define-syntax (aliased? stx)
  (syntax-case stx (value)
    [(_ (value expr) y)
     #'#f]
    [(_ x (value expr))
     #'#f]
    [(_ x y)
     (if (and (identifier? #'x) (identifier? #'y))
         (syntax-protect #'(alias-handler x 1 y (alias-handler y 2 x (do-aliased? x y))))
         (raise-syntax-error #f "not an identifier" stx (if (identifier? #'x) #'y #'x)))]))

(define-syntax-rule (do-aliased? x y)
  (let-syntax ([result (syntax-rules (x) [(_ x) #t] [(_ y) #f])])
    (result y)))

#;(define-syntax-rule (do-aliased? x y)
  (free-identifier=? #'x #'y))

(define-syntax (alias? stx)
  (syntax-case stx ()
    [(_ id)
     #`(alias-handler id #f #f
                      #f)]))

(define-syntax (unalias stx)
  (syntax-case stx ()
    [(_ id)
     #`(alias-handler id 0 #f
                      #f ; returns if not an alias
                      )]))