;; lod.scm -- Law of Demeter checker in Fred.

(module lod "../fred.scm"
  (provide violate-lod global-variable-values the-a)

  (define (remove-duplicates l)
    (foldr adjoin '() l))

  (define (intersect? l1 l2)
    (ormap (lambda (x1) (memq x1 l2)) l1))

  (define (subset? l1 l2)
    (andmap (lambda (x1) (memq x1 l2)) l1))

  (define-field argument-associations dp? '())
  (define-method add-argument-association! ((dp? dp) (object? obj))
    (set-argument-associations! dp (adjoin obj (get-argument-associations dp))))
  (define-method add-argument-association! ((dp? dp) (list? l))
    (for-each (lambda (obj) (add-argument-association! dp obj)) l))
  (define-method add-argument-association! ((dp? dp) val)
    ;; Ignore non-objects.
    (void))

  ;; Is a message being sent to an argument of the previous message send?
  (define (send-to-prev-arg? dp)
    (and (dp-previous dp)
	 (intersect? (dp-args dp) (dp-args (dp-previous dp)))))

  ;; ...remember its return value as an association of the argument.
  (define-after (&& send-to-prev-arg?
		    (! (cflow (call add-argument-association!))))
    (lambda (dp)
      (let ((val (dp-value dp)))
	(add-argument-association! (dp-previous dp) val))))

  (define-field locally-created-instances dp? '())
  (define-method add-locally-created-instance! ((dp? dp) (object? obj))
    (set-locally-created-instances!
     dp (cons obj (get-locally-created-instances dp))))

  ;; Associate instances upon creation with all the enclosing decision points.
  (define-after (&& (call make) (! (cflow (call add-locally-created-instance!))))
    (lambda (dp)
      (let ((instance (dp-value dp)))
	(for-each (lambda (dp) (add-locally-created-instance! dp instance))
		  (dp-all-previous dp)))))

  (define (global-variable-values)
    (remove-duplicates
     (map (lambda (variable)
	    (namespace-variable-value variable #t (lambda () #f)))
	  (namespace-mapped-symbols))))

  (define (potential-preferred-suppliers dp)
    (let ((prev (dp-previous dp)))
      (remove-duplicates
       (append (filter object? (dp-args prev))
	       (get-argument-associations prev)
	       (get-locally-created-instances prev)
	       (filter object? (global-variable-values))
	       ;; FIXME: all accessible variables, not just globals
	       ))))

  ;; We need to make a special exception for sending init messages
  ;; inside make methods, because we can't catch calls to make-object.
  (define init-inside-make?
    (&& (call init) (args class? object? ..)
	(cflow (&& (call make) (args class? ..)))))

  (define lod-violation?
    (&& (cflowbelow ?) ;not at top-level
	(! init-inside-make?)
	(! (cflow (call get-argument-associations get-locally-created-instances)))
	(! (call add-argument-association! add-locally-created-instance!))
	(lambda (dp)
	  ;; FIXME: what if one of the args is a list of objects?
	  (not (subset? (filter object? (dp-args dp))
			(potential-preferred-suppliers dp))))))

  (define-before lod-violation?
    (lambda (dp)
      (printf "Law of Demeter violation: ~a within ~a~%"
	      (unparse-dp dp) (unparse-dp (dp-previous dp)))
      (printf "Potential preferred suppliers: ~a~%"
	      (potential-preferred-suppliers dp))))

  (define-class a () (b))
  (define-class b () (c))
  (define-class c () (d))
  (define-class d () ())

  (define the-a (make a (make b (make c (make d)))))

  (define-method clone ((a an-a))
    (make a (get-b an-a)))
  (define-method plus ((number? x) (number? y))
    (+ x y))

  (define-method violate-lod ((a an-a))
    ;; Not a violation: sending a message to an argument
    (get-b an-a)
    ;; Not a violation: sending a message to an argument's field
    (get-c (get-b an-a))
    ;; FIXME: lists
    ;; Not a violation: sending a message to a locally created object
    (get-b (clone an-a))
    ;; Not a violation: sending a message to a global object
    (get-b the-a)
    ;; Not a violation: sending a message to a non-object
    (plus (plus 1 2) 3)
    ;; A violation:
    (get-d (get-c (get-b an-a)))
    (void))

  (define-method violate-lod ()
    (violate-lod (clone the-a)))
)