; (require :agnostic-lizard)
(asdf:load-system :agnostic-lizard)
; (use-package :agnostic-lizard)

(defpackage :agnostic-lizard-tests
  (:use :common-lisp :agnostic-lizard))
(in-package :agnostic-lizard-tests)

; different kind of expand can be defined

(defmacro expand-f (form &key names never-pass-fallback-env &environment e)
  `(macroexpand-all ',form ',e :names ',names
                    :never-pass-fallback-env ,never-pass-fallback-env))
(defmacro expand-m (form) `(macro-macroexpand-all ,form))
(defmacro to-expanded (form) `(macro-walk-form ,form))

(defvar *default-verbose* nil
  "Whether verbose debugging output has to be printed")

(defmacro check-eval-form (form &key (verbose *default-verbose*)
                                names never-pass-fallback-env wrapper-function)
  "Generate code checking correctness of expanding a form that can be eval-ed.
This means that the correct expansion of the form may not depend on any lexical
variable/function bindings (macros are OK).
Correctness is defined just as returning the same value.

Wrapper function could be used to create a lexical environment.
"
  `(let*
     ((form-fe (expand-f ,form :names ,names
                         :never-pass-fallback-env ,never-pass-fallback-env))
      (form-me (expand-m ,form))
      (form-fe-w (funcall (or ,wrapper-function 'identity) form-fe))
      (form-me-w (funcall (or ,wrapper-function 'identity) form-me))
      (value-oe ,form)
      (value-fe (eval form-fe-w))
      (value-me (eval form-me-w)))
     (if
       (and
         (equalp value-oe value-fe)
         (equalp value-oe value-me))
       ,(when verbose
          `(format *trace-output* "Checking form in eval OK:~{~%~S~}~%----~%"
                   (list ',form form-fe form-me value-oe)))
       (progn
         (format
           *error-output*
           (concatenate
             'string
             "Mismatch when checking form:~%~s~%"
             "Functional expansion:~%~S~%Macro-assisted expansion:~%~S~%"
             "Original form value:~%~S~%"
             "Functional expansion value: ~a~%~S~%"
             "Macro-assisted expansion value: ~a~%~S~%")
           ',form form-fe form-me value-oe
           (if (equalp value-oe value-fe) "OK" "!!") value-fe
           (if (equalp value-oe value-me) "OK" "!!") value-me)
         (throw :eval-check-failed "Form expansion changed behaviour")))))

(defmacro check-lexenv-form (form &key (verbose *default-verbose*))
  "Generate code checking correctness of expanding a form that does use the
lexical bindings of variables or functions."
  `(progn
     ,(when verbose
        `(format *trace-output* "Checking form in lexenv:~%~S~%~S~%~S~%----~%"
                 ',form (expand-m ,form) ,form))
     (unless
       (equalp ,form (to-expanded ,form))
       (throw :lexenv-check-fail "Form expansion changed behaviour"))))

(defmacro full-check-form (form &key (verbose *default-verbose*)
                                names never-pass-fallback-env wrapper-function)
  "Generate code for both possible kinds of checks on a form."
  `(progn
     (check-eval-form ,form :verbose ,verbose :names ,names
                      :never-pass-fallback-env ,never-pass-fallback-env
                      :wrapper-function ,wrapper-function)
     (check-lexenv-form ,form :verbose ,verbose)))

; Basic "making sense" checks
(full-check-form 1)
(full-check-form (let ((x 1)) x))
(macrolet ((f () 1)) (full-check-form (f)))
(macrolet ((f () 1)) (full-check-form (flet ((f () 2)) (f))))
(full-check-form (list 2 2 (quote a)))
(let ((x 1)) (check-lexenv-form (list x)))

; A show-off of passing data through macrolet

(defmacro depth-limited-macro (n-max on-failure &body body &environment env)
  (let*
    ((depth-value
       (macroexpand-1
         '(depth-counter-virtual-macro) env))
     (depth (if (numberp depth-value) depth-value 0)))
    (if
      (> depth n-max)
      ; Maximum macro depth reached
      on-failure
      (progn
        `(macrolet
           ((depth-counter-virtual-macro () ,(1+ depth)))
           ,@body)))))

(full-check-form
  (depth-limited-macro
    2
    (depth-limited-macro
      1
      (depth-limited-macro 1 :max-depth :test))))

(full-check-form
  (depth-limited-macro
    2 :max-depth
    (depth-limited-macro
      1 :max-depth
      (depth-limited-macro 2 :max-depth :test))))

(depth-limited-macro
  2 :max-depth
  (depth-limited-macro
    1 :max-depth
    (full-check-form
      (depth-limited-macro 1 :max-depth :test))))

(depth-limited-macro
  2 :max-depth
  (depth-limited-macro
    1 :max-depth
    (full-check-form
      (depth-limited-macro 2 :max-depth :test))))

(defmacro circular-depth-limited-macro ()
  #1=(depth-limited-macro 100 :max-depth #1#))

(full-check-form
  (circular-depth-limited-macro)
  ; printing the form is impossible
  :verbose nil)

(full-check-form (depth-limited-macro 2 nil (depth-limited-macro 3 nil (depth-counter-virtual-macro))))
(depth-limited-macro 2 nil (depth-limited-macro 3 nil (full-check-form (depth-counter-virtual-macro))))
(depth-limited-macro 2 nil (full-check-form (depth-limited-macro 3 nil (depth-counter-virtual-macro))))

; New macroexpand-dammit fails on that
(defmacro test-macro-just-one () 1)
(full-check-form '(flet ((test-macro-just-one () 2)) (test-macro-just-one)))
(flet ((test-macro-just-one () 2))
  (full-check-form
    (test-macro-just-one)
    :wrapper-function (lambda (x) `(flet ((test-macro-just-one () 2)) ,x))
    :never-pass-fallback-env t))
(flet ((test-macro-just-one () 2))
  (full-check-form
    (test-macro-just-one)
    :wrapper-function (lambda (x) `(flet ((test-macro-just-one () 2)) ,x))))

; Both old and new macroexpand-dammit fail here
(full-check-form (macrolet ((test-macro-just-one () 2)) (macrolet () (test-macro-just-one))))
(macrolet ((test-macro-just-one () 2)) (full-check-form (macrolet () (test-macro-just-one))))
(macrolet ((test-macro-just-one () 2)) (macrolet () (full-check-form (test-macro-just-one))))

; Parameters shadowing symbol-macros in flet
(full-check-form
  (symbol-macrolet
    ((x 1))
    (macrolet
      ((f (x) `(+ ,x 2))
       (g (x) `(+ ,x 3)))
      (flet
        ((f (x) (+ x 4))
         (g (y) (f (+ x y 5))))
        (g 77)))))
(symbol-macrolet
  ((x 1))
  (full-check-form
    (macrolet
      ((f (x) `(+ ,x 2))
       (g (x) `(+ ,x 3)))
      (flet
        ((f (x) (+ x 4))
         (g (y) (f (+ x y 5))))
        (g 77)))))
(symbol-macrolet
  ((x 1))
  (macrolet
    ((f (x) `(+ ,x 2))
     (g (x) `(+ ,x 3)))
    (full-check-form
      (flet
        ((f (x) (+ x 4))
         (g (y) (f (+ x y 5))))
        (g 77)))))
(symbol-macrolet
  ((x 1))
  (macrolet
    ((f (x) `(+ ,x 2))
     (g (x) `(+ ,x 3)))
    (flet
      ((f (x) (+ x 4))
       (g (y) (f (+ x y 5))))
      (check-lexenv-form
        (g 77)))))

; the latest fork of macroexpand-dammit had a problem with that
(full-check-form (funcall (lambda (x) x) :test))
(full-check-form (progn (setf (symbol-function 'just-a-test-function) #'1+)
                        (defun just-a-test-function (x) x)
                        (just-a-test-function 123)))

; a silly set of macrolet tests
(full-check-form
  (macrolet ((ff (x) `(list ',x ',x)))
    (macrolet
      ((gg (y) `(ff ,y)))
      (gg (1 2)))))
(macrolet ((ff (x) `(list ',x ',x)))
  (full-check-form
    (macrolet
      ((gg (y) `(ff ,y)))
      (gg (1 2)))))
(macrolet ((ff (x) `(list ',x ',x)))
  (macrolet
    ((gg (y) `(ff ,y)))
    (full-check-form
      (gg (1 2)))))

(full-check-form
  (macrolet ((ff (x) `(list ',x ',x)))
    (macrolet
      ((gg (y) `(ff ,y)))
      (gg 3))))
(macrolet ((ff (x) `(list ',x ',x)))
  (full-check-form
    (macrolet
      ((gg (y) `(ff ,y)))
      (gg 3))))
(macrolet ((ff (x) `(list ',x ',x)))
  (macrolet
    ((gg (y) `(ff ,y)))
    (full-check-form
      (gg 3))))

(full-check-form
  (loop for j from 1 to 3 collect j))

(full-check-form
  (progn
    (defun test-loop-function
      (x y) (loop for j from 1 to 3 collect (+ x y j 1)))
    (test-loop-function 12 36)))

; quasi-unit-tests
(full-check-form (block nil 1))
(full-check-form (block nil (return 2) 1))

(full-check-form '(1 2))

(full-check-form (funcall (symbol-macrolet ((x y)) (lambda (x) (+ x 1))) 1))

(macrolet
  ((f (x) `(list ,x 1)))
  (full-check-form (f (f 2))))
(full-check-form
  (macrolet
    ((f (x) `(list ,x 1)))
    (f (f 2))))

;Tests from hu.dwim.walker
(full-check-form
  (macrolet ((++ (&body body)
                 (reverse body)))
    (++ 1 2 3 -)))
(macrolet ((++ (&body body)
               (reverse body)))
  (full-check-form
    (++ 1 2 3 -)))

(full-check-form
  (let ((obj (make-instance 'metaenv)))
    (with-slots ((x agnostic-lizard::fallback-env)) obj
      x)))

; Just for the error handlers etc.
(full-check-form (multiple-value-list (ignore-errors 1)))
(full-check-form (ignore-errors (/ 1 (parse-integer "0"))))

; This is legal Common Lisp
(full-check-form ((lambda (x y) (macrolet ((f (x y op) `(,op ,x ,y 1))) (f y x +))) 5 7))

(full-check-form
  (macrolet ((f (name) (macroexpand-1 `(defun ,name () 1))))
    (f test-function-name-for-defun-macroexpand)
    (test-function-name-for-defun-macroexpand)))

; Lambda list test
(full-check-form
  (symbol-macrolet 
    ((x 2))
    (list
      (funcall (lambda (&optional (y 3 x)) x y))
      (funcall (lambda (&optional (y 3 x)) y x))
      (funcall (lambda (&optional (y 3 x)) y x) 4))))

(assert
  (equal 
    (third (macroexpand-all
             '(macrolet ((f () 1)) (lambda (&optional (x (f)))))))
    '(function (lambda (&optional (x 1))))))

; A test of overrides
; This is impossible without hints; and the default policy is wrong even
; with (incomplete) hints
(macrolet
  ((read-x-y
     (&environment e)
     `'(,(macroexpand-1 'x e)
         ,(macroexpand-1 'y e))))
  (symbol-macrolet
    ((x 1))
    (full-check-form
      (symbol-macrolet
        ((y 2))
        (read-x-y))
      ; Tell macroexpand-all about the extra variables used
      :names (x y) :never-pass-fallback-env t)))

; A test of complete overrides without policy override
(macrolet
  ((read-x-y
     (&environment e)
     `'(,(macroexpand-1 'x e)
         ,(macroexpand-1 'y e))))
  (symbol-macrolet
    ((x 3))
    (full-check-form
      (symbol-macrolet
        ((y 4))
        (read-x-y))
      ; Tell macroexpand-all about the extra variables used
      :names (x y read-x-y))))

; stupid robustness check
(assert
  (equal
    (eval
      (agnostic-lizard:macroexpand-all
        `(block
           nil
           ,(macroexpand-1
              '(handler-bind
                 ((error (lambda (e) (return (type-of e)))))
                 (/ 0 (min 0 (1- (get-universal-time)))))))))
    (block nil
           (handler-bind
             ((error (lambda (e) (return (type-of e)))))
             (/ 0 (min 0 (1- (get-universal-time))))))))

(format *error-output* "Example run complete.~%")
