;; WARNING: This file is intended for use with the repo's Github Actions.
;; We install some packages, possibly unneeded ones, then run the tests.

(setq needed-libraries
      '(s cl-lib dash seq))

(require 'package)
(push '("melpa" . "https://melpa.org/packages/") package-archives)
(package-initialize)
(unless package-archive-contents
  (package-refresh-contents))
(dolist (pkg needed-libraries)
  (unless (package-installed-p pkg)
    (package-install pkg)))

(load-file "lf.el")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Personal Testing Utils ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(defmacro deftest (desc tags &rest body)
  "Declare tests with meaningful string names, that reflect the test's main goal.

DESC is a string, TAGS is a vector.

The first tag should be the name of the main function being tested;
this name is prepended to the name of underlying ert-deftest.
This way, tests are grouped/namespaced when running ert from the command line.

Example ERT call: (ert '(tag my-cool-tag))"
  `(ert-deftest ,(intern
                  (concat
                   (format "%s::" (seq-elt tags 0))
                   (seq-map (lambda (c) (if (<= 65 c 122) c ?_))
                                   desc))) ()
     :tags (quote ,(seq--into-list tags))
     ,@body))
  ;; Convert all non-letters to â€˜_â€™; A = 65, z = 122.
  ;; Without the replace, â€œM-x ertâ€� crashes when it comes to selecting the test
  ;; to run.

(defmacro â‰‹ (lhs rhs)
    "A shorthand for (should (equal LHS RHS))."
    `(should (equal ,lhs ,rhs)))

(defmacro â†¯ (form &optional message)
    "The given FORM should error (with MESSAGE, ignoring whitespace).

Example: (â†¯ (error \"hola\") \"hola\")

Pictogram explanation: You've made such a big mistake, that the
heavens strike you down with a lightening bolt â†¯â†¯"
  (if message
      `(should (equal (s-collapse-whitespace (cl-second (should-error ,form)))
                      (s-collapse-whitespace ,message)))
    `(should-error ,form)))


;; I like the shapes: (Ã— some-crashing-form) and (â†¯ crashes with-this-message)
(defalias 'âœ“ 'should)
(defalias 'Ã— 'â†¯)


(defmacro â‡� (expr &rest regexp)
    "The given EXPR should match the given REGEXP, which is wrapped by â€˜rxâ€™.

REGEXP could also be a string, in which case we are doing string equality.
Either way, whitespace is ignored in both arguments.

The symbol â€œâ‡�â€� should be read â€œrewrites toâ€� or â€œelaborates toâ€�.

I prefer this form since it has the main form we're asserting
against-at the forefront and makes it clear we're matching
against strings.

For example,

  (should (s-matches? \"An English greeting.\" (documentation 'speak)))

Becomes:

  (â‡� (documentation 'speak) \"An English greeting.\")

Pictogram explanation: A given expression â€œrewrites, reduces,â€� to
a given matching pattern. Such arrows are popular in Term Rewriting Systems."
  `(should (s-matches? (s-collapse-whitespace (rx ,(cons 'seq regexp)))
                       (s-collapse-whitespace ,expr))))

(deftest "It works as expected, for multi-line strings"
  [lf-string]
  (â‰‹ (lf-string    "0. This is the first line, it has zero indentation.
                     1. This line indicates the indentation offset for the remaining lines.
                     2. As such, this line has no indentation.
                        3. But this one is clearly indentated (relative to line 1)")

"0. This is the first line, it has zero indentation.
1. This line indicates the indentation offset for the remaining lines.
2. As such, this line has no indentation.
   3. But this one is clearly indentated (relative to line 1)"))

(deftest "It works as expected, for single-line strings"
  [lf-string]
  (â‰‹ (lf-string "Hello my friends") "Hello my friends"))

(deftest "It allows interpolation, on a single line"
  [lf-string]
  (â‰‹
   (let ((you 'Jasim))
     (lf-string "me and ${you} like the number ${(+ 2 3)}"))
   "me and Jasim like the number 5"))

(deftest "It allows interpolation, spread over multiple"
  [lf-string]
  (â‰‹
   (lf-string "Did you know that
               ${(documentation

                    'apply)}
               is super cool!")

"Did you know that
Call FUNCTION with our remaining args, using our last arg as list of args.
Then return the value FUNCTION returns.
Thus, (apply '+ 1 2 '(3 4)) returns 10.

(fn FUNCTION &rest ARGUMENTS)
is super cool!"))

(deftest "It allows interpolation, involving string literals"
  [lf-string]
  (â‰‹
   (let ((you 'Jasim))
     (lf-string "${(concat \"m\" \"e\")} and ${you}"))
     "me and Jasim"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; lf-extract-optionals-from-rest ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmacro â‡’ (x y z  _  a b c)
    "Shorthand: (â‡’ inputs :become outputs)"
  `(â‰‹ (lf-extract-optionals-from-rest ,x #'vectorp ,y #'stringp ,z) (quote (,a ,b ,c))))

(deftest "[vector-then-string]What if we don't have a vector first? Then we're starting the rest!"
  [lf-extract-optionals-from-rest]
  (â‡’ nil nil nil :becomes nil nil nil)
  (â‡’ 'x nil nil :becomes nil nil (x))
  (â‡’ 'x 'y nil :becomes nil nil (x y))
  (â‡’ 'x 'y '(z) :becomes nil nil (x y z)))

(deftest "[vector-then-string]What if we don't have a vector first, but have a string instead!"
  [lf-extract-optionals-from-rest]
  (â‡’ "x" 'y '(z) :becomes nil "x" (y z))
  (â‡’ "x" 'y nil  :becomes nil "x" (y))
  (â‡’ "x" nil '(z) :becomes nil "x" (z))
  (â‡’ "x" nil nil  :becomes nil "x" nil))

(deftest "[vector-then-string]What if we do have a vector first?"
  [lf-extract-optionals-from-rest]
  ;; â€¦ followed by a string
  (â‡’ [] "" '(z) :becomes [] "" (z))
  (â‡’ [] "" nil :becomes [] "" nil)
  ;; â€¦ followed by a non-string; i.e., the start of the rest
  (â‡’ [] 'y '(z) :becomes [] nil (y z)))


(defmacro â‡’â‚‚ (x y z  _  a b c)
    "Shorthand: (â‡’ inputs :become outputs)"
  `(â‰‹ (lf-extract-optionals-from-rest ,x #'stringp ,y #'numberp ,z) (quote (,a ,b ,c))))

(deftest "[string-then-number]What if we don't have a number first? Then we're starting the rest!"
  [lf-extract-optionals-from-rest]
  (â‡’â‚‚ nil nil nil :becomes nil nil nil)
  (â‡’â‚‚ 'x nil nil :becomes nil nil (x))
  (â‡’â‚‚ 'x 'y nil :becomes nil nil (x y))
  (â‡’â‚‚ 'x 'y '(z) :becomes nil nil (x y z)))

(deftest "[string-then-number]What if we don't have a string first, but have a number instead!"
  [lf-extract-optionals-from-rest]
  (â‡’â‚‚ 34 'y '(z) :becomes nil  34 (y z))
  (â‡’â‚‚ 34 'y nil  :becomes nil  34 (y))
  (â‡’â‚‚ 34 nil '(z) :becomes nil 34 (z))
  (â‡’â‚‚ 34 nil nil  :becomes nil 34 nil))

(deftest "[string-then-number]What if we do have a string first?"
  [lf-extract-optionals-from-rest]
  ;; â€¦ followed by a string
  (â‡’â‚‚ "" 0 '(z) :becomes "" 0 (z))
  (â‡’â‚‚ "" 0 nil :becomes  "" 0 nil)
  ;; â€¦ followed by a non-number; i.e., the start of the rest
  (â‡’â‚‚ "" 'y '(z) :becomes "" nil (y z)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; lf-define ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(deftest "We can define both variables and functions"
  [lf-define]

  (lf-undefine age speak) ;; Ensure we have undefined names to use.
  (lf-define age 29)
  (â‰‹ age 29)

  (lf-define speak (name) (format "Hello, %s!" name))
  (â‰‹ (speak 'bob) "Hello, bob!"))

(deftest "If PLACE is a non-atomic form, then we default to using â€˜setfâ€™."
  [lf-define setf]
  (lf-undefine foods)
  (lf-define foods '(apple banana))
  (lf-define (car foods) 'pineapple)
  (â‰‹ foods '(pineapple banana)))

(deftest "It â€œzapsâ€�:  (lf-define x (f it))  â‰ˆ  (setq x (f x))"
  [lf-define]

  ;; A super simple zap!
  (lf-define x 12)
  (lf-define x (+ it 1))  ;; Note the â€˜itâ€™
  (â‰‹ x 13)

  ;; Let's see a lengthier example, without zapping
  (lf-undefine age)
  (lf-define age 12)
  (setf (documentation-property 'age 'variable-documentation)
        (or "Ugly way to update docs" (documentation-property 'age 'variable-documentation)))
  (â‰‹ "Ugly way to update docs" (documentation-property 'age 'variable-documentation))

  ;; Zap!
  (lf-define (documentation-property 'age 'variable-documentation)
             (or "New way to update docs" it))
  (â‰‹ "New way to update docs" (documentation-property 'age 'variable-documentation))

  ;; Another zap!
  (lf-define (documentation-property 'age 'variable-documentation)
             (format "woah, %s" it))
  (â‰‹ "woah, New way to update docs" (documentation-property 'age 'variable-documentation)))

(deftest "It documents variables"
  [lf-define]
  (lf-undefine age) ;; Ensure we have undefined names to use.
  (lf-define age 29 "How old am I?")
  (â‰‹ (lf-documentation 'age) "How old am I?"))

(deftest "It can define strings, which can also be documented"
  [lf-define]
  (lf-undefine name)
  (lf-define name "Bobert" "What is my name?")
  (â‰‹ (lf-documentation 'name) "What is my name?"))

(deftest "It can define strings, which do not need documentation"
  [lf-define]
  (lf-undefine name)
  (lf-define name "Bobert")
  (â‰‹ name "Bobert")
  (â‰‹ (lf-documentation 'name) nil))

(deftest "It can define strings, with typing and docstrings"
  [lf-define]
  (lf-undefine name)
  (lf-define name "Bobert" [:type string] "What is my name?")
  (â‰‹ (lf-documentation 'name) "What is my name?"))

(deftest "It can define strings with types, but do docstring"
  [lf-define]
  (lf-undefine name)
  (lf-define name "Bobert" [:type string])
  (â‰‹ (lf-documentation 'name) nil)
  (â‰‹ name "Bobert"))

;; The new constraints are not checked against the new value!
(deftest "New constraints on variables override any existing ones"
  [lf-define]
  (lf-undefine age)

  ;; Initial value satisfies declared constraints
  (lf-define age "12" [:type string])

  ;; New *initial* value satisifes OLD constraints, which are dismissed
  ;; in-favour of the newly declared constraints. The new value does not
  ;; satisfy the new constraints.
  (â†¯ (lf-define age "12" [(and (integerp it) (stringp it))])
      "Error: Initial value â€œ12â€� violates declared constraint:
        [(and (integerp it) (stringp it))]

       As such, symbol â€œageâ€� is now unbound and unconstrained.")

  ;; New initial value satisfies the newly declared constraints
  (âœ“ (lf-define age 9 [(and (integerp it) (<= 0 it 10))]))

  ;; Yet again...
  (lf-undefine age) ;; Ensure we have undefined names to use.
  (âœ“ (lf-define age 29 [:type integer] "How old am I?")) ;; OK
  (âœ“ (lf-define age "twenty-nine" [:type string] "How old am I?")) ;; OK
  (âœ“ (lf-define age 'twenty-nine [:type symbol])) ;; OK
  )

(deftest "It allows us to define documented vector variables"
  [lf-define]
  (lf-undefine foods) ;; Ensure we have undefined names to use.
  (lf-define foods [shorba dolma] "What Iraqi foods do I like?")
  (â‰‹ foods [shorba dolma])
  (â‰‹ (documentation-property 'foods 'variable-documentation) "What Iraqi foods do I like?"))

(deftest "It allows us to define undocumented vector variables"
  [lf-define]
  (lf-undefine foods) ;; Ensure we have undefined names to use.
  (lf-define foods [shorba dolma])
  (â‰‹ foods [shorba dolma])
  (â‰‹ (documentation-property 'foods 'variable-documentation) nil))

(deftest "It allows us to define undocumented but typed vector variables"
  [lf-define]
  (lf-undefine foods) ;; Ensure we have undefined names to use.
  (lf-define foods [shorba dolam] [:type vector])
  (â‰‹ (documentation-property 'foods 'variable-documentation) nil)
  (â‰‹ foods [shorba dolam]))

(deftest "It defines documented functions"
  [lf-define]
  (lf-undefine speak) ;; Ensure we have undefined names to use.
  (lf-define speak (name) "An English greeting." (format "Hello, %s!" name))
  (â‡� (documentation #'speak) "An English greeting."))

;; lf-define does not allow the direct definition of empty functions (always â€œnilâ€�
;; functions), which is okay since they are seldom used in practice.
(deftest "It does not allow the direct definition of empty functions"
  [lf-define]

  (lf-undefine f)
  (lf-define f ()) ;; Warning: This is not the empty function; but is the empty list!
  (â‰‹ f nil)
  (â‰‹ (documentation-property 'f 'variable-documentation) nil)

  (lf-undefine f)
  (lf-define f () "Docs") ;; Warning: This is not the empty function; but is a documented empty list!
  (â‰‹ f nil)
  (â‰‹ (documentation-property 'f 'variable-documentation) "Docs")

  (lf-undefine f)
  (lf-define f () "Docs" nil) ;; Warning: This is not the empty function; but is a documented empty list!
  (â‰‹ f nil)
  (â‰‹ (documentation-property 'f 'variable-documentation) "Docs")

  (lf-undefine id) ;; Ensure we have undefined names to use.
  (lf-define id (x) "Identity" x)
  (â‡� (documentation #'id) "Identity")

  ;; We also cannot have empty functions that take arguments...
  ;; (lf-undefine f)
  ;; (lf-define f (x) "Docs") ;; Warning: This is not an empty function; but is a function call! We call â€œxâ€� with no arguments!
  ;; (lf-define f (x y)) ;; This sets â€œfâ€� to be the result of â€œxâ€� applied to â€œyâ€�!

  (lf-undefine f)
  (lf-define f () "Woah!" (and nil)) ;; This is an /indirect/ definition of an empty function
  (â‰‹ (f) nil)
  (â‡� (documentation #'f) "Woah!")

  (lf-undefine f)
  (lf-define f (x y) "Woah!" (and nil)) ;; This is an /indirect/ definition of an empty function, with args.
  (â‰‹ (f 1 2) nil)
  (â‡� (documentation #'f ) "Woah!"))

(deftest "It can define typed functions"
  [lf-define]

  (lf-undefine speak) ;; Ensure we have undefined names to use.

  (lf-define speak (name age)
             [:requires (and (stringp name) (integerp age))
              :ensures (stringp result)]
             "Greet person NAME with their AGE."
             (format "Hello %s year-old %s!" age name))

  ;; Docstring is present
  (â‡� (documentation #'speak)
     "This function has :around advice: â€˜lf--specify/speakâ€™.

      Greet person NAME with their AGE.

      (fn NAME AGE)")

  ;; Type-satisfied inputs yield an output
  (â‰‹ (speak "musa" 29) "Hello 29 year-old musa!")

  ;; Type-invalid inputs yield an error
  (â†¯ (speak 'musa 29)           ;; i.e., symbol â‰  string.
     "Error: Requirements for â€œspeakâ€� have been violated.

      REQUIRED:
      (and
       (stringp name)
       (integerp age))

      GIVEN:
      ((name = musa : symbol)
       (age = 29 : integer))   ")

  ;; Uh-oh! We accidentally have an erroneous return type ;-|
  (lf-define speak (name age)
             [:requires (and (stringp name) (integerp age))
              :ensures (stringp result)]
             12)
  ;; Any use yields an error:
  (â†¯ (speak "musa" 29)
     "Panic! There is an error in the implementation of â€œspeakâ€�.
     Claimed guarantee: (stringp result)
     Actual result value: 12 ---typed: integer"))



;; Function definition expansions

(deftest "It expands function definitions to cl-defun's, with typing advice"
  [lf-define]
  (â‡� (pp-to-string (macroexpand '(lf-define add (x) (+ 1 x))))
     "(cl-defun add (x)
        nil
        (+ 1 x))

      (lf-specify add (x) :requires t :ensures t)"))

(deftest "It expands documented function definitions correctly, with typing advice"
  [lf-define]
  (â‡� (pp-to-string (macroexpand '(lf-define add (x) "Hola" (+ 1 x))))
     " (cl-defun add (x)
         \"Hola\"
         (+ 1 x))

      (lf-specify add (x) :requires t :ensures t)"))

(deftest "It expands typed, and documented, function definitions into cl-defun's, with typing advice"
  [lf-define]
  (â‡� (pp-to-string (macroexpand '(lf-define add (x) [:requires (integerp x)] "My docs" (+ 1 x))))
     "(cl-defun add (x)
        \"My docs\"
        (+ 1 x))

      (lf-specify add (x) :requires (integerp x) :ensures t)"))



;; When does a function panic/error out?

(deftest "Poorly implemented functions panic when used"
  [lf-define]
  (lf-undefine speak)
  (lf-define speak (name age)
           [ :ensures (vectorp result) ]
          "Given a NAME and AGE, present a nice greeting."
           (format "Hello, %s!" name))
  (â†¯ (speak "mesa" 12)
     "Panic! There is an error in the implementation of â€œspeakâ€�.

      Claimed guarantee: (vectorp result)

      Actual result value: \"Hello, mesa!\" ---typed: string"))

(deftest "Coorectly implemented functions do not panic when used with well-typed arguments"
  [lf-define]
  (lf-undefine speak)
  (lf-define speak (name age)
           [:requires (and (stringp name) (integerp age))
            :ensures (stringp result) ]
           "Given a NAME and AGE, present a nice greeting."
           (format "Hello, %s!" name))

  (âœ“ (speak "mesa" 12))
  (â†¯ (speak 'whoops 12)
     "Error: Requirements for â€œspeakâ€� have been violated.

      REQUIRED:
      (and
       (stringp name)
       (integerp age))

      GIVEN:
      ((name = whoops : symbol)
       (age = 12 : integer))     "))




;; ðŸ”¥ Post assertions can be relative to input and output arguments

(deftest "Post assertions can be relative to input and output arguments"
  [lf-define]
  (lf-undefine next)
  (lf-define next (x)
             "This function resturns a value strictly greater than input X."
             [:requires (integerp x)
              :ensures  (< x result)]
             (1+ x))
  (â‰‹ (next 2) 3))




;; :fire: It lets you use pre- and post-conditions with custom error messages, by using or-error

(deftest "It lets you use pre- and post-conditions with custom error messages, by using or-error"
  [lf-define]
  (lf-undefine go)
  (lf-define go (x) [:requires (or (integerp x) (error "I asked you for a bloody integer!"))] x)
  (âœ“ (go 3))
  (â†¯ (go "3") "I asked you for a bloody integer!"))
