#cs
(module minijava-check mzscheme
  (require (lib "reduction-semantics.ss" "reduction-semantics")
           (lib "helper.ss" "reduction-semantics")
           (lib "list.ss")
           "minijava.ss")

  (provide :-p)
  
  ;; `:-p' is straightforward, except that we
  ;;  have to wrap the use of `:-e' with 
  ;;  `first-result' on :-e. More on that below.
  (define :-p
    (lang-match-lambda (P) minijava-grammar
      [((name cls cl) ... (name M M))
       (and (classes-once? P)
            (object-builtin? P)
            (fields-once-per-class? P)
            (methods-once-per-class? P)
            (classes-defined? P)
            (well-founded-classes? P)
            (overrides-consistent? P)
            (andmap (:-d P) cls)
            (first-result (:-e P null M)))]
      [any #f]))

  ;; `:-d' is straightforward
  (define (:-d P) 
    (lambda (cl) (::-d P cl)))
  (define ::-d
    (lang-match-lambda* (P cl) cl minijava-grammar
      [(class (name c c) extends c
         ((name fls fl) ...) ((name mts mt) ...))
       (and (andmap (:-f P) fls)
            (andmap (:-m P c) mts))]
      [else #f]))
  
  ;; `:-f' uses `:-e' on `V', and then checks whether
  ;; the result type matches the declared type. But
  ;; `:-e' might assign many different types to `V',
  ;; so we use `explore-results' to find one that
  ;; matches, if any. Check V using :-s to allow subtypes.
  (define (:-f P) 
    (lambda (fl) (::-f P fl)))
  (define ::-f
    (lang-match-lambda* (P fl) fl minijava-grammar
      [((name T T) (name f f) = (name V V))
       (first-result
        (explore-results (T2) (:-s P null V)
          (and (eq? T T2)
               T)))]))
  
  ;; `:-m' is similar to `:-f': check the body
  ;; and compare to the declared type. Check the
  ;; body using :-s to allow subtypes.
  (define (:-m P c)
    (lambda (mt) (::-m P c mt)))
  (define ::-m
    (lang-match-lambda* (P c mt) mt minijava-grammar
      [((name T T) (name m m) (((name Ts T) (name Xs X)) ...) (name M M))
       (first-result
        (explore-results (body-T) (:-s P
                                       (cons (cons 'this c) (map cons Xs Ts))
                                       M)
          (and (eq? body-T T)
               T)))]))
  
  ;; ':-e' is not a function in the notes. For example, the
  ;; rule of `null' can give the expression any class type.
  ;; A complete typing thus involves a backtracking exploration
  ;; of possible results. Thus, all calls to `:-e' involve
  ;; uses of `explore-results' (especially recursive calls) or
  ;; `first-result' (when any result will do).
  (define :-e
    (lang-match-lambda* (P e orig-M) orig-M minijava-grammar
      [(new (name c c)) c]
      [null (many-results (all-cs P))]
      [(name X X) (let ([a (assq X e)])
                    (and a (cdr a)))]
      [((name M M) : (name c c) |.| (name f f))
       (explore-results (c2) (:-e P e M)
         ;; c2 must be a class type...
         (and (c? c2)
              ;; ... and it must have a c.f field
              (let ([TV (inf_ P c f c2)])
                (and TV
                     (car TV)))))]
      [((name M M) : (name c c) |.| (name f f) := (name M2 M))
       (explore-results (c2) (:-e P e M)
         ;; like the previous rule...
         (and (c? c2)
              (let ([lhs-T (let ([TV (inf_ P c f c2)])
                             (and TV
                                  (car TV)))])
                (and lhs-T
                     ;; ... except that we also explore types for the RHS,
                     ;; looking for a match to the field's declared type;
                     ;; note thst we use :-s for the RHS
                     (explore-results (rhs-T) (:-s P e M2)
                       (and (eq? rhs-T lhs-T)
                            rhs-T))))))]
      [((name M M) |.| (name m m) ((name Ms M) ...))
       (explore-results (c) (:-e P e M)
         ;; M must have a class type...
         (and (c? c)
              ;; ... and that class must have method `m' ...
              (let ([cTsTXsM (inm_ P c m)])
                ;; ... expecting as many arguments a s provided ...
                (and cTsTXsM
		     (= (length (cadr cTsTXsM)) (length Ms))
                     ;; ... and where the actual arguments can be
                     ;; given types that match the declared types;
                     ;; note that we use :-s for the arguments
                     (explore-parallel-results (arg-Ts) (map (lambda (M) (:-s P e M)) Ms)
                       (and (andmap eq? arg-Ts (cadr cTsTXsM))
                            (caddr cTsTXsM)))))))]
      [(super (name X X) : (name c c) |.| (name m m) ((name Ms M) ...))
       (let ([a (assq X e)])
         (and a
              ;; X must have a class type that is an immediate declared
              ;; subtype of c
              (c? (cdr a))
              (<_ P (cdr a) c)
              ;; And c must have the method m...
              (let ([cTsTXsM (inm_ P c m)])
		(and cTsTXsM
		     ;;  ... consistent with the actual-argument types;
		     ;;  again, we use :-s
		     (explore-parallel-results (arg-Ts) (map (lambda (M) (:-s P e M)) Ms)
                       (and (andmap eq? arg-Ts (cadr cTsTXsM))
			    (caddr cTsTXsM)))))))]
      [(((name c c)) (name M M))
       ;; Cast works as long as M has a class type
       (explore-results (c2) (:-e P e M)
         (and (c? c2) c))]
      [b 'num]
      [((name o1 o1) (name M M))
       (explore-results (T) (:-e P e M)
         (and (eq? T 'num)
              'num))]
      [((name o2 o2) (name M1 M) (name M2 M))
       (explore-parallel-results (Ts) (list (:-e P e M1) (:-e P e M2))
         (and (eq? (car Ts) 'num)
              (eq? (cadr Ts) 'num)
              'num))]
      [any #f]))
  
  (define (:-s P e M)
    (explore-results (T) (:-e P e M)
      (many-results (cons T
                          (filter (lambda (c)
                                    (and (not (eq? c T))
                                         (<=_ P T c)))
                                  (all-cs P)))))))