(module checks mzscheme

  (require "syntax-errors.scm"
           "syntax-indirection.scm"
           "metadata.scm"
           "sharing.scm"
           "idmap.scm"
           "tags.scm"
           (lib "etc.ss")
           (lib "list.ss")
           (planet "combinators.ss" ("cce" "combinators.plt" 1 4)))

  (provide check-identifiers!
           check-identifier!
           check-unique-identifiers!
           check-same-identifiers!
           check-interface-identifiers!
           check-assigned-identifiers!
           check-module-identifiers!
           check-module-identifier!
           check-identifier-subset!
           check-linked-interfaces!
           check-sharing!
           check-primitive-sharing!
           check-compound-sharing!)

  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  ;;
  ;;  Syntactic checks
  ;;
  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

  (define (check-identifiers! ids)
    (for-each check-identifier! (syntax->list ids)))

  (define (check-identifier! id)
    (unless (identifier? id)
      (syntax-error id "expected an identifier")))

  (define (check-unique-identifiers! ids)
    (let* ([dup (check-duplicate-identifier (syntax->list ids))])
      (when dup (syntax-error dup "duplicate name"))))

  (define (check-same-identifiers! ones twos)
    (for-each check-same-identifier!
              (syntax->list ones)
              (syntax->list twos)))

  (define (check-same-identifier! one two)
    (unless (eq? (syntax-e one) (syntax-e two))
      (syntax-error two "expected same name as ~s" (syntax-e one))))

  (define (check-interface-identifiers! ids)
    (for-each check-interface-identifier! (syntax->list ids)))

  (define (check-interface-identifier! id)
    (unless (ifc-meta? (read-syntax-indirection id))
      (syntax-error id "expected an interface name")))

  (define (check-assigned-identifiers! tags ifcs externals)
    (for-each check-assigned-interface!
              (syntax->list ifcs)
              (syntax->list externals)))

  (define (check-assigned-interface! ifc externals)
    (let* ([imeta (read-syntax-indirection ifc)]
           [actuals (syntax->list externals)]
           [formals (ifc-funs imeta)])
      (for-each check-same-identifier! formals actuals)))

  (define (check-module-identifiers! ids)
    (for-each check-module-identifier! (syntax->list ids)))

  (define (check-module-identifier! id)
    (unless (mod-meta? (read-syntax-indirection id))
      (syntax-error id "expected a module name")))

  (define (check-identifier-subset! subs supers)
    (let* ([super-ids (syntax->list supers)]
           [alist (map (lambda (id) (cons id #t)) super-ids)]
           [set (alist->idmap alist)])
      (for-each
       (lambda (id)
         (unless (idmap-member? set id)
           (syntax-error id "definition not found")))
       (syntax->list subs))))

  (define (check-linked-interfaces! itags ifaces
                                    mods args ltags
                                    etags efaces)
    (let* ([ifcs (map read-syntax-indirection (syntax->list ifaces))]
           [efcs (map read-syntax-indirection (syntax->list efaces))]
           [tags (alist->idmap (map cons (syntax->list itags) ifcs))])
      (for-each (curry check-linked-module! tags)
                (syntax->list mods)
                (syntax->list args)
                (syntax->list ltags))
      (for-each (curry check-linked-interface! tags)
                (syntax->list etags) efcs)))

  (define (check-linked-module! tags mod args ltags)
    (let* ([meta (read-syntax-indirection mod)]
           [ifaces (map (curry mod-ifc meta) (mod-imports meta))]
           [efaces (map (curry mod-ifc meta) (mod-exports meta))])
      (for-each (curry check-linked-interface! tags) (syntax->list args) ifaces)
      (for-each (curry idmap-put-unique! tags) (syntax->list ltags) efaces)))

  (define (check-linked-interface! tags id ifc)
    (let* ([src (idmap-get tags id (lambda () (tag-not-found! id)))])
      (unless (eq? src ifc)
        (syntax-error id "interface ~s does not match ~s"
                      (syntax-e (ifc-name ifc)) (syntax-e (ifc-name src))))))

  (define (tag-not-found! id)
    (syntax-error id "cannot find interface with tag ~s" (syntax-e id)))

  (define (check-sharing! tags ids clauses)
    (let* ([tags (syntax->list tags)]
           [ids (syntax->list ids)]
           [ifcs (map read-syntax-indirection ids)]
           [clauses (syntax->list clauses)]
           [shared (map syntax->list clauses)]
           [idset (empty-idset)])
      (for-each (curry add-tagged-names! idset) tags ifcs)
      (for-each (curry check-shared-name! idset) (apply append shared))))

  (define (add-tagged-names! idset tag ifc)
    (for-each (curry add-tagged-name! idset tag) (ifc-funs ifc)))

  (define (add-tagged-name! idset tag id)
    (idset-add-unique! idset (tag-id tag id)))

  (define (check-shared-name! idset id) (void))

  (define (check-primitive-sharing! meta defs tags externals internals)
    (let* ([import-sharing (mod-import-sharing meta)]
           [export-sharing (mod-export-sharing meta)]
           [tagged-externals
            (map (lambda (tag ids) (map (curry tag-id tag) ids))
                 tags externals)]
           [assign-clauses
            (map list (apply append tagged-externals) (apply append internals))]
           [total-sharing
            (sharing-add-clauses assign-clauses #f import-sharing)])
      (unless (sharing-subset? export-sharing total-sharing)
        (syntax-error (mod-original meta)
                      "export sharing on module ~s unsatifsied"
                      (syntax-e (mod-name meta))))))

  (define (check-compound-sharing! meta mods args tags)
    (let* ([initial (mod-import-sharing meta)]
           [cumulative (foldl (curry check-link-sharing! meta)
                              initial mods args tags)]
           [goal (mod-export-sharing meta)])
      (unless (sharing-subset? goal cumulative)
        (syntax-error (mod-original meta)
                      "export sharing on module ~s unsatisfied"
                      (syntax-e (mod-name meta))))))

  (define (check-link-sharing! main mod args tags sharing)
    (let* ([meta (read-syntax-indirection mod)]
           [imports (mod-imports meta)]
           [exports (mod-exports meta)]
           [itag-alist (map cons imports args)]
           [etag-alist (map cons exports tags)]
           [before (mod-import-sharing meta)]
           [after (mod-export-sharing meta)]
           [before/tag (sharing-retag itag-alist before)]
           [after/tag (sharing-retag (append itag-alist etag-alist) after)])
      (unless (sharing-subset? before/tag sharing)
        (syntax-error mod
                      "link sharing in tags ~s of module ~s unsatisfied"
                      (map syntax-e tags)
                      (syntax-e (mod-name main))))
      (sharing-union sharing after/tag)))

  )