;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; environment.ss
;; Richard Cobbe
;;
;; Functions that define a standard rib-cage environment data type.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(module environment mzscheme

  (require (lib "contract.ss")
           (lib "etc.ss"))

  (define-struct env ())
  (define-struct (empty-env env) ())
  (define-struct (rib-env env) (env ids bindings))
  ;; (Env X Y) ::= (make-empty-env)
  ;;             | (make-rib-env (Env X Y) (listof X) (listof Y))

  (define-struct (exn:env:unbound exn:fail:contract) (id) (make-inspector))

  ;; lookup :: (Env X Y) X [(X X -> Boolean) (-> Z)] -> (Union Y Z)
  ;; looks up id in env according to id-eq?; calls fk if not found.
  ;; default fk raises exn:env:unbound.
  (define lookup
    (opt-lambda (env id
                     [id-eq? eq?]
                     [fk (lambda ()
                           (raise (make-exn:env:unbound
                                   "lookup: unbound ID"
                                   (current-continuation-marks)
                                   id)))])
      (recur outer-loop ([env env])
        (if (empty-env? env)
            (fk)
            (recur inner-loop ([ids (rib-env-ids env)]
                               [bindings (rib-env-bindings env)])
              (cond
                [(null? ids) (outer-loop (rib-env-env env))]
                [(id-eq? (car ids) id) (car bindings)]
                [else (inner-loop (cdr ids) (cdr bindings))]))))))

  ;; env->alist :: (Env X Y) -> (Listof (List X Y))
  ;; Converts an environment to an alist for easy printing
  (define env->alist
    (lambda (env)
      (cond
       [(empty-env? env) null]
       [else (append (map list (rib-env-ids env) (rib-env-bindings env))
                     (env->alist (rib-env-env env)))])))

  ;; (env-macro [a b] [(c d) e]) ==>
  ;;    (extend-env (make-empty-env) (list 'a '(c d)) (list b e))
  (define-syntax env-macro
    (syntax-rules ()
      [(_) (make-empty-env)]
      [(_ (key val) ...)
       (make-rib-env (make-empty-env)
                   (list (quote key) ...)
                   (list val ...))]))

  (provide [rename env-macro env])

  ;; extend-env raises an exn:fail if the two lists are of different lengths.
  ;; (This is a contract violation---why is this not exn:fail:contract?)

  (provide/contract [env? (-> any/c boolean?)]
                    [make-empty-env (-> env?)]
                    [lookup (opt-> (env? any/c)
                                   [(-> any/c any/c boolean?)
                                    (-> any)]
                                   any)]
                    [rename make-rib-env extend-env
                            (->r ([env env?]
                                  [syms list?]
                                  [bindings
                                   (lambda (b)
                                     (and (list? b)
                                          (= (length syms)
                                             (length b))))])
                                 env?)]
                    [env->alist (-> env? (listof list?))]
                    [struct (exn:env:unbound exn:fail:contract)
                            ([message string?]
                             [continuation-marks continuation-mark-set?]
                             [id any/c])]))