<commit_before>;;;; © 2016-2019 <NAME>         - license: GNU AGPLv3 -*- coding: utf-8 -*-

(in-package #:petalisp.test-suite)

(defclass testing-backend (backend)
  ((%reference-backend
    :reader reference-backend
    :initform (petalisp.reference-backend:make-reference-backend))
   (%ir-backend
    :reader ir-backend
    :initform (petalisp.ir-backend:make-ir-backend))
   (%native-backend
    :reader native-backend
    :initform
    #+nil
    (petalisp.ir-backend:make-ir-backend)
    (petalisp.native-backend:make-native-backend))))

(defun make-testing-backend ()
  (make-instance 'testing-backend))

(defmethod compute-immediates ((data-structures list) (testing-backend testing-backend))
  (with-accessors ((reference-backend reference-backend)
                   (ir-backend ir-backend)
                   (native-backend native-backend)) testing-backend
    (let ((reference-solutions
            (compute-immediates data-structures reference-backend)))
      (loop for backend in (list ir-backend native-backend) do
        (loop for immediate in (compute-immediates data-structures backend)
              for expected-immediate in reference-solutions
              for index from 0 do
                (is (approximately-equal
                     (lisp-datum-from-immediate immediate)
                     (lisp-datum-from-immediate expected-immediate)))))
      reference-solutions)))

(defmethod delete-backend ((testing-backend testing-backend))
  (delete-backend (reference-backend testing-backend))
  (delete-backend (ir-backend testing-backend))
  (delete-backend (native-backend testing-backend))
  (call-next-method))

(defun call-with-testing-backend (thunk)
  (let ((*backend* (make-testing-backend)))
    (unwind-protect (funcall thunk)
      (delete-backend *backend*))))

(defmacro with-testing-backend (&body body)
  `(call-with-testing-backend (lambda () ,@body)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Equality

(defgeneric approximately-equal (a b))

(defmethod approximately-equal ((a t) (b t))
  (eql a b))

(defmethod approximately-equal ((array-1 array) (array-2 array))
  (and (equal (array-dimensions array-1)
              (array-dimensions array-2))
       (loop for index below (array-total-size array-1)
             always (approximately-equal
                     (row-major-aref array-1 index)<commit_msg>Have the testing backend produce better stack traces on error.<commit_after>;;;; © 2016-2019 <NAME>         - license: GNU AGPLv3 -*- coding: utf-8 -*-

(in-package #:petalisp.test-suite)

(defclass testing-backend (backend)
  ((%reference-backend
    :reader reference-backend
    :initform (petalisp.reference-backend:make-reference-backend))
   (%ir-backend
    :reader ir-backend
    :initform (petalisp.ir-backend:make-ir-backend))
   (%native-backend
    :reader native-backend
    :initform
    #+nil
    (petalisp.ir-backend:make-ir-backend)
    (petalisp.native-backend:make-native-backend))))

(defun make-testing-backend ()
  (make-instance 'testing-backend))

(defmethod compute-immediates ((data-structures list) (testing-backend testing-backend))
  (with-accessors ((reference-backend reference-backend)
                   (ir-backend ir-backend)
                   (native-backend native-backend)) testing-backend
    (let ((reference-solutions
            (compute-immediates data-structures reference-backend))
          (ir-backend-solutions
            (compute-immediates data-structures ir-backend))
          (native-backend-solutions
            (compute-immediates data-structures native-backend)))
      (compare-solutions reference-solutions ir-backend-solutions)
      (compare-solutions reference-solutions native-backend-solutions)
      reference-solutions)))

(defun compare-solutions (solutions-1 solutions-2)
  (loop for immediate-1 in solutions-1
        for immediate-2 in solutions-2 do
          (is (approximately-equal
               (lisp-datum-from-immediate immediate-1)
               (lisp-datum-from-immediate immediate-2)))))

(defmethod delete-backend ((testing-backend testing-backend))
  (delete-backend (reference-backend testing-backend))
  (delete-backend (ir-backend testing-backend))
  (delete-backend (native-backend testing-backend))
  (call-next-method))

(defun call-with-testing-backend (thunk)
  (let ((*backend* (make-testing-backend)))
    (unwind-protect (funcall thunk)
      (delete-backend *backend*))))

(defmacro with-testing-backend (&body body)
  `(call-with-testing-backend (lambda () ,@body)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Equality

(defgeneric approximately-equal (a b))

(defmethod approximately-equal ((a t) (b t))
  (eql a b))

(defmethod approximately-equal ((array-1 array) (array-2 array))
  (and (equal (array-dimensions array-1)
              (array-dimensions array-2))
       (loop for index below (array-total-size array-1)
             always (approximately-equal
                     (row-major-aref array-1 index)
{'fraction_non_alphanumeric': 0.1590280521532991, 'fraction_numerical': 0.00809956538917424, 'mean_word_length': 3.2191666666666667, 'pattern_counts': {'":': 0, '<': 5, '<?xml version=': 0, '>': 5, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3087483', 'n_tokens_mistral': 1561, 'n_tokens_neox': 1476, 'n_words': 320}