;;; Written in PLT Scheme.
;   - should work in at least version 209 and higher
;
;   See  http://drscheme.org
;
;   Can run from command line as:
;
;     mzscheme --script check.scm < Bad.sexp



; Get some procedures from list library.
;   http://srfi.schemers.org/srfi-1/
;
; Recent versions of PLT Scheme can be more precise about imports:
;   (require (only (lib "1.ss" "srfi") first second filter any))
;
(require (lib "1.ss" "srfi"))

; Get some macros from pattern-matching library.
;   http://download.plt-scheme.org/doc/370/html/mzlib/mzlib-Z-H-27.html#node_chap_27
;
; For some examples from CSC 324 2006 Fall:
;   http://www.cs.toronto.edu/~gfb/csc324/2006F/branching
;
; So far we use patterns composed of: _, string and symbol literals, lists, ., or, ?,
;  binding, equality from binding
;
;(require (only (lib "match.ss") match match-lambda))
;
(require (lib "match.ss"))



; On first reading you can skip the implementations of match?-lambda
;  and sexp->list-of-subtree-sexps.

;;; General Matching
;
; (match?-lambda (<pattern> <result> ...)
;                ...)
;
; Convenient version of match-lambda for producing unary predicates
;  that simply test whether the argument matches one of the patterns,
;  though result processing is still available.
;
; Omitted result expressions default to #t, and non-match defaults to #f.
;
(define-syntax match?-lambda
  (syntax-rules ()
    ((_            (<pattern> <result> ...)
                   ...)
     (match-lambda (<pattern> #t <result> ...)
                   ...
                   (_ #f)))))

;;; General Tree/Sexp Manipulation
;
;  (sexp->list-of-subtree-sexps s)
;
;  Viewing s as a tree, return a list of all its subtrees.
;
;   I.e. return a list containing: s, elements of s, elements of elements of s, etc.
;   - doesn't enter improper lists.
;
;   Compared with flatten: includes intermediate expressions, not just leaves/atoms.
;
(define (sexp->list-of-subtree-sexps s)
  `(,s ,@(if (list? s) (apply append (map sexp->list-of-subtree-sexps s)) '())))



;;; Checks about Boolean Expressions
;
; - helper that matches literal true or false
;
(define t/f? (match?-lambda ((or "true" "false"))))
;
;  The checks ...
;
(define compares-boolean-literal?
  (match?-lambda (((or 'EQUAL 'NOT_EQUAL) .
                    (or ((? t/f?) _)
                        (_ (? t/f?)))))))
;
(define operates-on-boolean-literal?
  (match?-lambda
    (('LNOT (? t/f?)))
    (((or 'LAND 'LOR) .
        (or ((? t/f?) _)
            (_ (? t/f?)))))))
;
(define if-then-returns-boolean-literal?
  (match?-lambda
    (("if" _
      (or          ("return" ('EXPR (? t/f?)))
          ('SLIST  ("return" ('EXPR (? t/f?)))))
      (or          ("return" ('EXPR (? t/f?)))
          ('SLIST  ("return" ('EXPR (? t/f?)))))))))
;
(define distributed-boolean?
  (match?-lambda
    ((or ('LOR  ('LAND e11 e12) ('LAND e21 e22))
         ('LAND ('LOR  e11 e12) ('LOR  e21 e22)))
     (or (equal? e11 e21) (equal? e11 e22) (equal? e12 e21) (equal? e12 e22)))))



;;; Embedded line number handling
;
;
(define line-number (match-lambda (((_ ('line l)) . _) l)))
;
(define (strip-line-numbers s)
  (match s
    ((s0 ('line _)) s0)
    ((? list?) (map strip-line-numbers s))
    (_ s)))

(define (line-numbers-of check code)
  (map line-number
    (filter (lambda (s) (check (strip-line-numbers s)))
      (sexp->list-of-subtree-sexps code))))



;;; Running checks
;
;
(define (report-check check message code)
  (let ((line-numbers (line-numbers-of check code)))
    (if (not (null? line-numbers))
      (for-each display `("Line numbers " ,message ":"
                          ,@(map (lambda (l) (string-append " " (number->string l))) line-numbers)
                          ".\n")))))
;
(define checks
  `((,operates-on-boolean-literal? "operating (\"!\", \"&&\" or \"||\") on a boolean literal (\"true\" or \"false\")")
    (,compares-boolean-literal? "comparing (\"==\" or \"!=\") with boolean literal (\"true\" or \"false\")")
    (,if-then-returns-boolean-literal? "using if-else to return a boolean literal (\"true\" or \"false\")")
    (,distributed-boolean? "containing && of ||s or || of &&s, with a repeated condition tht can be factored out")))
;
(define code (read))
;
; For each check, report each line number where it occurs.
;
(map (match-lambda ((check message) (report-check check message code)))
  checks)